FreeLaunch

1
{
2
  ##########################################################################
3
  #  FreeLaunch is a free links manager for Microsoft Windows              #
4
  #                                                                        #
5
  #  Copyright (C) 2024 Alexey Tatuyko <feedback@ta2i4.ru>                 #
6
  #  Copyright (C) 2019 Mykola Petrivskiy                                  #
7
  #  Copyright (C) 2010 Joker-jar <joker-jar@yandex.ru>                    #
8
  #                                                                        #
9
  #  This file is part of FreeLaunch.                                      #
10
  #                                                                        #
11
  #  FreeLaunch is free software: you can redistribute it and/or modify    #
12
  #  it under the terms of the GNU General Public License as published by  #
13
  #  the Free Software Foundation, either version 3 of the License, or     #
14
  #  (at your option) any later version.                                   #
15
  #                                                                        #
16
  #  FreeLaunch is distributed in the hope that it will be useful,         #
17
  #  but WITHOUT ANY WARRANTY; without even the implied warranty of        #
18
  #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         #
19
  #  GNU General Public License for more details.                          #
20
  #                                                                        #
21
  #  You should have received a copy of the GNU General Public License     #
22
  #  along with FreeLaunch. If not, see <http://www.gnu.org/licenses/>.    #
23
  ##########################################################################
24
}
25

26
unit FLFunctions;
27

28
interface
29

30
uses
31
  Winapi.Windows, Winapi.Messages, System.Classes,
32
  Vcl.Graphics, Vcl.Imaging.PNGImage, Vcl.Themes, Vcl.Styles;
33

34

35

36
type
37

38
  TFLThemeInfo = record
39
    ID: Integer;
40
    Name: string;
41
    NameForGUI: string;
42
  end;
43

44
const
45
  UM_ShowMainForm = WM_USER + 1;
46
  UM_HideMainForm = WM_USER + 2;
47
  UM_LaunchDone   = WM_USER + 3;
48
  //default themes (integrated in exe)
49
  FLThemes : array [0..2] of TFLThemeInfo = (
50
      /// first theme is always classic
51
      (ID: 0; Name: 'Windows'; NameForGUI: 'Classic'),
52
      // second theme is always for Windows 10+ dark mode
53
      (ID: 1; Name: 'Windows10 SlateGray'; NameForGUI: 'Slate Gray'),
54
      /// third theme is always for Windows 10+ light mode
55
      (ID: 2; Name: 'Windows10'; NameForGUI: 'Light')
56
    );
57

58

59
type
60
  TAByte = array [0..maxInt-1] of byte;
61
  TPAByte = ^TAByte;
62
  TRGBArray = array[Word] of TRGBTriple;
63
  pRGBArray = ^TRGBArray;
64

65
  TLink = record
66
    ltype: byte;
67
    active: boolean;
68
    exec: string;
69
    workdir: string;
70
    icon: string;
71
    iconindex: integer;
72
    params: string;
73
    dropfiles: boolean;
74
    dropparams: string;
75
    descr: string;
76
    ques: boolean;
77
    hide: boolean;
78
    pr: byte;
79
    wst: byte;
80
    IsAdmin: Boolean;
81
    AsAdminPerm: Boolean;
82
  end;
83

84
  //--Структура информации о ярлыке
85
  TShellLinkInfoStruct = record
86
    FullPathAndNameOfLinkFile: array[0..MAX_PATH] of Char;
87
    FullPathAndNameOfFileToExecute: array[0..MAX_PATH] of Char;
88
    ParamStringsOfFileToExecute: array[0..MAX_PATH] of Char;
89
    FullPathAndNameOfWorkingDirectroy: array[0..MAX_PATH] of Char;
90
    Description: array[0..MAX_PATH] of Char;
91
    FullPathAndNameOfFileContiningIcon: array[0..MAX_PATH] of Char;
92
    IconIndex: Integer;
93
    HotKey: Word;
94
    ShowCommand: Integer;
95
    FindData: TWIN32FINDDATA;
96
  end;
97
  PShellLinkInfoStruct = ^TShellLinkInfoStruct;
98

99
// Функция не позволяет уйти значению за пределы допустимых
100
function InRange(Value, FromV, ToV: byte): byte;
101
// Функции определяют количество иконок в файле
102
function GetIconCount(FileName: string): integer;
103
function GetNegativeCount(FileName: string): Integer;
104
// Функция извлекает иконку из файла по индексу
105
function GetFileIcon(FileName: string; Index: integer; Size: Integer = 32): HIcon;
106
// Функция возвращает путь к специальным папкам в Windows
107
function GetSpecialDir(const CSIDL: Byte): string;
108
function GetAbsolutePath(s: string): string;
109
// Преобразование битмапа в PNG с сохранением альфы
110
procedure AlphaToPng(Src: TBitmap; Dest: TPngImage);
111
// Функция делает ресайз изображения
112
procedure SmoothResize(Src, Dst: TBitmap);
113
// Функция извлекает описание исполняемого файла
114
function GetFileDescription(FileName: string): string;
115
// Функция извлекает имя файла без разширения
116
function ExtractFileNameNoExt(FileName: string): string;
117
// Функция извлекает информацию из ярлыка (*.lnk)
118
procedure GetLinkInfo(lpShellLinkInfoStruct: PShellLinkInfoStruct);
119
// Обрезает строку Str до длины Len с добавлением троеточия в конец
120
function MyCutting(Str: string; Len: byte): string;
121
// Простая обертка над MessageBox
122
procedure WarningMessage(AHandle: HWND; AText: string);
123
/// MessageBox with YES and NO buttons
124
function RequestMessage(AHandle: HWND; AText: string): Integer;
125
// Определение типа файла
126
function IsExecutable(Ext: string): Boolean;
127
// Обертка над CreateProcess
128
function CreateProcessFL(AExecutable, AParameters, APath: string; AWindowState,
129
  APriority: Integer; var AErrorCode: Integer): Boolean;
130
// Запуск процесса внутри потока
131
procedure ThreadLaunch(var ALink: TLink; AMainHandle: HWND; ADroppedFile: string);
132
// Процедура для запуска процесса в потоке (при клике по кнопке)
133
procedure NewProcess(ALink: TLink; AMainHandle: HWND; ALaunchID: Integer;
134
  ADroppedFile: string);
135
// launch help file
136
procedure ExecHelpFile(AMainHandle: HWND; AHelpFileName: string);
137
// Замена всех переменных окружения их значениями
138
function ExpandEnvironmentVariables(const AFileName: string): string;
139
// Добавление новой переменной окружения
140
procedure AddEnvironmentVariable(const AName, AValue: string);
141
// Конвертация линка в набор строк
142
procedure LinkToStrings(ALink: TLink; AStrings: TStrings);
143
/// <summary> Конвертация набора строк в линк </summary>
144
function StringsToLink(AStrings: TStrings): TLink;
145
/// <summary> Рисует иконку Щит UAC на канве </summary>
146
procedure DrawShieldIcon(ACanvas: TCanvas; APosition: TPoint; ASize: TSize);
147
/// <summary> Инициализация путей </summary>
148
procedure InitEnvironment;
149
/// <summary> Проверка режима работы программы </summary>
150
function IsPortable: Boolean;
151
/// <summary> Конвертация пути в путь с использованием переменных окружения </summary>
152
function PathToPortable(APath: string): string;
153
/// Check Windows visual theme
154
function WinThemeDetect: string;
155
/// Get current App visual theme
156
function GetAppTheme: string;
157
/// Get index of visual theme by name
158
function GetAppThemeIndex(AName: string): Integer;
159
/// Set App visual theme
160
procedure SetAppTheme(AName: string);
161
/// Set App visual theme by ID
162
function FindSysUserDefLangFile: string;
163

164
var
165
  fl_root, fl_dir, fl_WorkDir, FLVersion: string;
166
  SettingsMode: integer; //Режим работы (0 - инсталляция, настройки хранятся в APPDATA;
167
  //1 - инсталляция, настройки хранятся в папке программы;
168
  //2 - портабельный режим, инсталляция, настройки хранятся в папке программы)
169

170
implementation
171

172
uses
173
  System.SysUtils, System.IniFiles, System.IOUtils, System.StrUtils,
174
  System.Win.ComObj, System.Win.Registry, System.Math,
175
  Winapi.CommCtrl, Winapi.ShellApi, Winapi.ShFolder, Winapi.ActiveX,
176
  Winapi.ShlObj,
177
  FLLanguage;
178

179
type
180

181
  PBGRAInt = ^TBGRAInt;
182

183
  TBGRAInt = record
184
    R: Integer;
185
    G: Integer;
186
    B: Integer;
187
    A: Integer;
188
  end;
189

190
  PBGRA = ^TBGRA;
191

192
  TBGRA = packed record
193
    B: Byte;
194
    G: Byte;
195
    R: Byte;
196
    A: Byte;
197
  end;
198

199

200
  PContributor = ^TContributor;
201

202
  TContributor = record
203
    Weight:  Integer;
204
    Pixel:   Integer;
205
  end;
206

207
  TContributors = array of TContributor;
208

209
  PContributorEntry = ^TContributorEntry;
210
  TContributorEntry = record
211
    N:            Integer;
212
    Contributors: TContributors;
213
  end;
214

215
  TContributorList = array of TContributorEntry;
216

217
  TBGRAIntArray = array of TBGRAInt;
218

219
procedure FillLineCacheHorz(N: Integer; Line: Pointer;
220
                              const ACurrentLine: TBGRAIntArray);
221
var
222
  Run:  PBGRA;
223
  Data: PBGRAInt;
224
begin
225
  Run := Line;
226
  Data := @ACurrentLine[0];
227
  Dec(N);
228
  while N >= 0 do begin
229
    Data.B := Run.B;
230
    Data.G := Run.G;
231
    Data.R := Run.R;
232
    Data.A := Run.A;
233
    Inc(Run);
234
    Inc(Data);
235
    Dec(N);
236
  end;
237
end;
238

239
function IntToByte(Value: Integer): Byte;
240
begin
241
  Result := 255;
242
  if Value >= 0 then begin
243
    if Value <= 255 then Result := Value;
244
  end else Result := 0;
245
end;
246

247
function BitmapFilter(Value: Single): Single;
248
const
249
  B = 1.0 / 3.0;
250
  C = 1.0 / 3.0;
251
  OneSixth = 1.0 / 6.0;
252
var
253
  Temp: Single;
254
begin
255
  if Value < 0.0 then Value := - Value;
256
  Temp := Sqr(Value);
257
  if Value < 1.0 then begin
258
    Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * Temp)) +
259
              ((-18.0 + 12.0 * B + 6.0 * C) * Temp) + (6.0 - 2.0 * B));
260
    Result := Value * OneSixth;
261
  end else
262
    if Value < 2.0 then begin
263
      Value := (((-B - 6.0 * C) * (Value * Temp)) +
264
                ((6.0 * B + 30.0 * C) * Temp) +
265
                ((-12.0 * B - 48.0 * C) * Value) +
266
                (8.0 * B + 24.0 * C));
267
      Result := Value * OneSixth;
268
    end else Result := 0.0;
269
end;
270

271
procedure FillLineCacheVert(N, Delta: Integer; Line: Pointer;
272
                              const ACurrentLine: TBGRAIntArray);
273
var
274
  Run: PBGRA;
275
  Data: PBGRAInt;
276
begin
277
  Run := Line;
278
  Data := @ACurrentLine[0];
279
  Dec(N);
280
  while N >= 0 do begin
281
    Data.B := Run.B;
282
    Data.G := Run.G;
283
    Data.R := Run.R;
284
    Data.A := Run.A;
285
    Inc(PByte(Run), Delta);
286
    Inc(Data);
287
    Dec(N);
288
  end;
289
end;
290

291
function ApplyContributors(Contributor: PContributorEntry;
292
                            const ACurrentLine: TBGRAIntArray): TBGRA;
293
var
294
  J, Total, Weight: Integer;
295
  RGB:              TBGRAInt;
296
  Contr:            PContributor;
297
  Data:             PBGRAInt;
298
begin
299
  Total := 0;
300
  RGB.B := Total;
301
  RGB.G := Total;
302
  RGB.R := Total;
303
  RGB.A := Total;
304
  Contr := @Contributor.Contributors[0];
305
  for J := 0 to Contributor.N - 1 do begin
306
    Weight := Contr.Weight;
307
    Inc(Total, Weight);
308
    Data := @ACurrentLine[Contr.Pixel];
309
    Inc(RGB.R, Data.R * Weight);
310
    Inc(RGB.G, Data.G * Weight);
311
    Inc(RGB.B, Data.B * Weight);
312
    Inc(RGB.A, Data.A * Weight);
313
    Inc(Contr);
314
  end;
315
  Result.B := IntToByte(IfThen(Total <> 0, RGB.B div Total, RGB.B shr 8));
316
  Result.G := IntToByte(IfThen(Total <> 0, RGB.G div Total, RGB.G shr 8));
317
  Result.R := IntToByte(IfThen(Total <> 0, RGB.R div Total, RGB.R shr 8));
318
  Result.A := IntToByte(IfThen(Total <> 0, RGB.A div Total, RGB.A shr 8));
319
end;
320

321
procedure DoStretch(Source, Target: TBitmap);
322
var
323
  ScaleX, ScaleY: Single;
324
  I, J, K, N: Integer;
325
  Center: Single;
326
  Width: Single;
327
  Weight: Integer;
328
  Left, Right: Integer;
329
  Work: TBitmap;
330
  ContributorList: TContributorList;
331
  SourceLine, DestLine: PBGRA;
332
  DestPixel: PBGRA;
333
  Delta, DestDelta: Integer;
334
  SourceHeight, SourceWidth: Integer;
335
  TargetHeight, TargetWidth: Integer;
336
  CurrentLine: TBGRAIntArray;
337
begin
338
  SourceHeight := Source.Height;
339
  SourceWidth := Source.Width;
340
  TargetHeight := Target.Height;
341
  TargetWidth := Target.Width;
342
  Work := TBitmap.Create;
343
  try
344
    Work.PixelFormat := pf32bit;
345
    Work.Height := SourceHeight;
346
    Work.Width := TargetWidth;
347
    ScaleX := IfThen(SourceWidth = 1, TargetWidth / SourceWidth,
348
                      Pred(TargetWidth) / Pred(SourceWidth));
349
    ScaleY := IfThen(SourceHeight = 1, TargetHeight / SourceHeight,
350
                      Pred(TargetHeight) / Pred(SourceHeight));
351
    SetLength(ContributorList, TargetWidth);
352
    if ScaleX < 1 then begin
353
      Width := 2.0 / ScaleX;
354
      for I := 0 to Pred(TargetWidth) do begin
355
        ContributorList[I].N := 0;
356
        Center := I / ScaleX;
357
        Left := System.Math.Floor(Center - Width);
358
        Right := System.Math.Ceil(Center + Width);
359
        SetLength(ContributorList[I].Contributors, Right - Left + 1);
360
        for J := Left to Right do begin
361
          Weight := Round(BitmapFilter((Center - J) * ScaleX) * ScaleX * 256);
362
          if Weight <> 0 then begin
363
            if J < 0 then N := -J
364
            else  N := IfThen(J >= SourceWidth, 2 * SourceWidth - J - 1, J);
365
            K := ContributorList[I].N;
366
            Inc(ContributorList[I].N);
367
            ContributorList[I].Contributors[K].Pixel := N;
368
            ContributorList[I].Contributors[K].Weight := Weight;
369
          end;
370
        end;
371
      end;
372
    end else begin
373
      for I := 0 to Pred(TargetWidth) do begin
374
        ContributorList[I].N := 0;
375
        Center := I / ScaleX;
376
        Left := System.Math.Floor(Center - 2.0);
377
        Right := System.Math.Ceil(Center + 2.0);
378
        SetLength(ContributorList[I].Contributors, Right - Left + 1);
379
        for J := Left to Right do begin
380
          Weight := Round(BitmapFilter(Center - J) * 256);
381
          if Weight <> 0 then begin
382
            if J < 0 then N := -J
383
            else N := IfThen(J >= SourceWidth, 2 * SourceWidth - J - 1, J);
384
            K := ContributorList[I].N;
385
            Inc(ContributorList[I].N);
386
            ContributorList[I].Contributors[K].Pixel := N;
387
            ContributorList[I].Contributors[K].Weight := Weight;
388
          end;
389
        end;
390
      end;
391
    end;
392
    if SourceWidth > SourceHeight then SetLength(CurrentLine, SourceWidth)
393
    else SetLength(CurrentLine, SourceHeight);
394
    for K := 0 to Pred(SourceHeight) do begin
395
      SourceLine := Source.ScanLine[K];
396
      FillLineCacheHorz(SourceWidth, SourceLine, CurrentLine);
397
      DestPixel := Work.ScanLine[K];
398
      for I := 0 to Pred(TargetWidth) do begin
399
        DestPixel^ := ApplyContributors(@ContributorList[I], CurrentLine);
400
        Inc(DestPixel);
401
      end;
402
    end;
403
    for I := 0 to Pred(TargetWidth) do ContributorList[I].Contributors := nil;
404
    ContributorList := nil;
405
    SetLength(ContributorList, TargetHeight);
406
    if ScaleY < 1 then begin
407
      Width := 2.0 / ScaleY;
408
      for I := 0 to Pred(TargetHeight) do begin
409
        ContributorList[I].N := 0;
410
        Center := I / ScaleY;
411
        Left := System.Math.Floor(Center - Width);
412
        Right := System.Math.Ceil(Center + Width);
413
        SetLength(ContributorList[I].Contributors, Right - Left + 1);
414
        for J := Left to Right do
415
        begin
416
          Weight := Round(BitmapFilter((Center - J) * ScaleY) * ScaleY * 256);
417
          if Weight <> 0 then begin
418
            if J < 0 then N := -J
419
            else N := IfThen(J >= SourceHeight, 2 * SourceHeight - J - 1, J);
420
            K := ContributorList[I].N;
421
            Inc(ContributorList[I].N);
422
            ContributorList[I].Contributors[K].Pixel := N;
423
            ContributorList[I].Contributors[K].Weight := Weight;
424
          end;
425
        end;
426
      end;
427
    end else begin
428
      for I := 0 to Pred(TargetHeight) do begin
429
        ContributorList[I].N := 0;
430
        Center := I / ScaleY;
431
        Left := System.Math.Floor(Center - 2.0);
432
        Right := System.Math.Ceil(Center + 2.0);
433
        SetLength(ContributorList[I].Contributors, Right - Left + 1);
434
        for J := Left to Right do begin
435
          Weight := Round(BitmapFilter(Center - J) * 256);
436
          if Weight <> 0 then begin
437
            if J < 0 then N := -J
438
            else N := IfThen(J >= SourceHeight, 2 * SourceHeight - J - 1, J);
439
            K := ContributorList[I].N;
440
            Inc(ContributorList[I].N);
441
            ContributorList[I].Contributors[K].Pixel := N;
442
            ContributorList[I].Contributors[K].Weight := Weight;
443
          end;
444
        end;
445
      end;
446
    end;
447
    SourceLine := Work.ScanLine[0];
448
    Delta := PAnsiChar(Work.ScanLine[1]) - PAnsiChar(SourceLine);
449
    DestLine := Target.ScanLine[0];
450
    DestDelta := PAnsiChar(Target.ScanLine[1]) - PAnsiChar(DestLine);
451
    for K := 0 to Pred(TargetWidth) do begin
452
      DestPixel := Pointer(DestLine);
453
      FillLineCacheVert(SourceHeight, Delta, SourceLine, CurrentLine);
454
      for I := 0 to Pred(TargetHeight) do begin
455
        DestPixel^ := ApplyContributors(@ContributorList[I], CurrentLine);
456
        Inc(Integer(DestPixel), DestDelta);
457
      end;
458
      Inc(SourceLine);
459
      Inc(DestLine);
460
    end;
461
    for I := 0 to Pred(TargetHeight) do ContributorList[I].Contributors := nil;
462
    ContributorList := nil;
463
  finally
464
    Work.Free;
465
    Target.Modified := True;
466
  end;
467
end;
468

469
procedure Stretch(NewWidth, NewHeight: Cardinal; Source: TGraphic;
470
                    Target: TBitmap);
471
var
472
  Temp:                 TBitmap;
473
  OriginalPixelFormat:  TPixelFormat;
474
begin
475
  if Source.Empty then Exit;
476
  Temp := TBitmap.Create;
477
  try
478
    Temp.Assign(Source);
479
    Temp.PixelFormat := pf32bit;
480
    OriginalPixelFormat := Target.PixelFormat;
481
    Target.FreeImage;
482
    Target.PixelFormat := pf32bit;
483
    Target.Width := NewWidth;
484
    Target.Height := NewHeight;
485
    DoStretch(Temp, Target);
486
    Target.PixelFormat := OriginalPixelFormat;
487
  finally
488
    Temp.Free;
489
  end;
490
end;
491

492
//--Функция не позволяет уйти значению за пределы допустимых
493
//--Входные параметры: значение, минимальное значение, максимальное значение
494
function InRange(Value, FromV, ToV: byte): byte;
495
begin
496
  Result := Value;
497
  if Value < FromV then Result := FromV;
498
  if Value > ToV then Result := ToV;
499
end;
500

501
//--Функция определяет количество иконок в файле
502
function GetIconCount(FileName: string): Integer;
503
var
504
  LIC, SIC: HICON;
505
begin
506
  Result := ExtractIconEx(PChar(FileName), -1, LIC, SIC, 1);
507
end;
508

509
function GetNegativeCount(FileName: string): Integer;
510
var
511
  LIC, SIC: HICON;
512
  icount, I: Integer;
513
begin
514
  Result := 0;
515
  icount := GetIconCount(FileName);
516
  LIC := 0;
517
  SIC := 0;
518
  for I := - icount + 1 to 0 do begin
519
    LIC := 0;
520
    SIC := 0;
521
    if ExtractIconEx(PChar(FileName), I, LIC, SIC, 1) <> 0 then begin
522
      Result := -I + 1;
523
      Break;
524
    end;
525
  end;
526
end;
527

528
function GetShellIcon(FileName: string): HIcon;
529
var
530
  SFI: TSHFileInfo;
531
begin
532
  ShGetFileInfo(PChar(FileName), 0, SFI, SizeOf(TShFileInfo), SHGFI_ICON);
533
  Result := SFI.hIcon;
534
end;
535

536
//--Функция извлекает иконку из файла по индексу
537
function GetFileIcon(FileName: string; Index, Size: Integer): HIcon;
538
var
539
  LIC, SIC: HICON;
540
begin
541
  Result := 0;
542
  if GetIconCount(FileName) > 0 then begin
543
    ExtractIconEx(PChar(FileName), Index, LIC, SIC, 1);
544
    Result := LIC;
545
    if Result = 0 then Result := SIC;
546
  end;
547
  if Result = 0 then Result := GetShellIcon(FileName);
548
  if Result = 0 then Result := LoadIcon(HInstance, 'RBLANKICON');
549
end;
550

551
//--Функция возвращает путь к специальным папкам в Windows
552
//--Входной параметр: идентификатор пути
553
//--  CSIDL_APPDATA - Application Data
554
//--  CSIDL_BITBUCKET - Корзина
555
//--  CSIDL_CONTROLS - Панель управления
556
//--  CSIDL_COOKIES - Cookies
557
//--  CSIDL_DESKTOP - Рабочий стол
558
//--  CSIDL_DESKTOPDIRECTORY - папка Рабочего стола
559
//--  CSIDL_DRIVES - Мой компьютер
560
//--  CSIDL_FAVORITES - Избранное
561
//--  CSIDL_FONTS - Шрифты
562
function GetSpecialDir(const CSIDL: byte): string;
563
var
564
  Buf: array[0..MAX_PATH] of Char;
565
begin
566
  Result := '';
567
  if SHGetFolderPath(0, CSIDL, 0, 0, Buf) = 0 then
568
    Result := Buf
569
  else
570
    exit;
571
  if Result[length(Result)] <> '\' then Result := Result + '\';
572
end;
573

574
function GetAbsolutePath(s: string): string;
575
begin
576
  result := ExpandEnvironmentVariables(s);
577
end;
578

579
type
580
  TRGBQuadArray  = array[0..MaxInt div sizeof(TRGBQuad) - 1] of TRGBQuad;
581
  PRGBQuadArray  = ^TRGBQuadArray;
582

583
procedure AlphaToPng(Src: TBitmap; Dest: TPngImage);
584
var
585
  X, Y: Integer;
586
  LineS:  PRGBQuadArray;
587
  ALineD: VCL.Imaging.PNGImage.PByteArray;
588
begin
589
  Src.PixelFormat := pf32bit; //На всякий случай
590
  Src.AlphaFormat := afIgnored;
591
  Dest.Assign(Src);
592
  Dest.CreateAlpha;
593

594
  for Y := 0 to Pred(Src.Height) do
595
  begin
596
    LineS  := Src.ScanLine[Y];
597
    ALineD := Dest.AlphaScanline[Y];
598

599
    for X := 0 to Pred(Src.Width) do
600
      ALineD[X] := LineS[X].rgbReserved;
601
  end;
602

603
  Src.AlphaFormat := afDefined;
604
  Dest.Modified := True;
605
end;
606

607

608
//--Функция делает ресайз изображения
609
procedure SmoothResize(Src, Dst: TBitmap);
610
begin
611
  Dst.PixelFormat := pf32bit;
612
  Stretch(Dst.Width, Dst.Height, Src, Dst);
613
  Dst.AlphaFormat := afDefined;
614
end;
615

616
//--Функция извлекает описание исполняемого файла
617
function GetFileDescription(FileName: string): string;
618
var
619
  P: Pointer;
620
  Value: Pointer;
621
  Len: UINT;
622
  GetTranslationString:string;
623
  FValid:boolean;
624
  FSize: DWORD;
625
  FHandle: DWORD;
626
  FBuffer: PChar;
627
begin
628
  FSize := 0;
629
  FBuffer := nil;
630
  try
631
    FValid := False;
632
    FSize := GetFileVersionInfoSize(PChar(FileName), FHandle);
633
    if FSize > 0 then
634
      begin
635
        GetMem(FBuffer, FSize);
636
        FValid := GetFileVersionInfo(PChar(FileName), FHandle, FSize, FBuffer);
637
      end;
638
    Result := '';
639
    if FValid then
640
      VerQueryValue(FBuffer, '\VarFileInfo\Translation', p, Len)
641
    else
642
      p := nil;
643
    if P <> nil then
644
      GetTranslationString := IntToHex(MakeLong(HiWord(Longint(P^)), LoWord(Longint(P^))), 8);
645
    if FValid then
646
      begin
647
        if VerQueryValue(FBuffer,
648
          PChar('\StringFileInfo\' + GetTranslationString + '\FileDescription'),
649
          Value, Len)
650
        then
651
          Result := StrPas(PChar(Value));
652
      end;
653
  finally
654
    if FBuffer <> nil then
655
      FreeMem(FBuffer, FSize);
656
  end;
657
end;
658

659
//--Функция извлекает имя файла без разширения
660
function ExtractFileNameNoExt(FileName: string): string;
661
var
662
  TempStr: string;
663
begin
664
  TempStr := ExtractFileName(FileName);
665
  Result := Copy(TempStr, 1, Length(TempStr) - Length(ExtractFileExt(FileName)));
666
end;
667

668
//--Функция извлекает информацию из ярлыка (*.lnk)
669
procedure GetLinkInfo(lpShellLinkInfoStruct: PShellLinkInfoStruct);
670
var
671
  ShellLink: IShellLink;
672
  PersistFile: IPersistFile;
673
  AnObj: IUnknown;
674
  ch_temp: array [0..MAX_PATH] of Char;
675
  s_temp: string;
676
begin
677
  AnObj  := CreateComObject(CLSID_ShellLink);
678
  ShellLink := AnObj as IShellLink;
679
  PersistFile := AnObj as IPersistFile;
680
  PersistFile.Load(PChar(string(lpShellLinkInfoStruct^.FullPathAndNameOfLinkFile)), 0);
681
  with ShellLink do
682
    begin
683
      GetPath(lpShellLinkInfoStruct^.FullPathAndNameOfFileToExecute, SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfLinkFile), lpShellLinkInfoStruct^.FindData, SLGP_RAWPATH);
684
      //32-bit app specific code for 64-bit Windows below
685
      if not FileExists(lpShellLinkInfoStruct^.FullPathAndNameOfFileToExecute) then
686
        begin
687
          ExpandEnvironmentStrings('%ProgramW6432%', ch_temp, SizeOf(ch_temp));
688
          SetString(s_temp, PChar(@ch_temp[0]), High(ch_temp));
689
          StrPCopy(lpShellLinkInfoStruct^.FullPathAndNameOfFileToExecute, StringReplace(lpShellLinkInfoStruct^.FullPathAndNameOfFileToExecute, GetSpecialDir(CSIDL_PROGRAM_FILES), IncludeTrailingPathDelimiter(TrimRight(s_temp)), [rfReplaceAll, rfIgnoreCase]));
690
        end;
691
      //end of specific code
692
      GetDescription(lpShellLinkInfoStruct^.Description, SizeOf(lpShellLinkInfoStruct^.Description));
693
      GetArguments(lpShellLinkInfoStruct^.ParamStringsOfFileToExecute, SizeOf(lpShellLinkInfoStruct^.ParamStringsOfFileToExecute));
694
      GetWorkingDirectory(lpShellLinkInfoStruct^.FullPathAndNameOfWorkingDirectroy, SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfWorkingDirectroy));
695
      GetIconLocation(lpShellLinkInfoStruct^.FullPathAndNameOfFileContiningIcon, SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfFileContiningIcon), lpShellLinkInfoStruct^.IconIndex);
696
      GetHotKey(lpShellLinkInfoStruct^.HotKey);
697
      GetShowCmd(lpShellLinkInfoStruct^.ShowCommand);
698
    end;
699
 end;
700

701
//--Обрезает строку Str до длины Len с добавлением троеточия в конец (если строка длинее Len)
702
function MyCutting(Str: string; Len: byte): string;
703
begin
704
  if Length(Str) <= Len then
705
    Result := Str
706
  else
707
    Result := Copy(Str, 1, Len) + '...';
708
end;
709

710
function RequestMessage(AHandle: HWND; AText: string): Integer;
711
begin
712
  Result := MessageBox(AHandle, PChar(AText),
713
    PChar(Language.Messages.Confirmation),
714
    MB_YESNO or MB_ICONQUESTION or MB_DEFBUTTON2 or MB_TOPMOST);
715
end;
716

717
procedure WarningMessage(AHandle: HWND; AText: string);
718
begin
719
  MessageBox(AHandle, PChar(AText), PChar(Language.Messages.Caution),
720
    MB_ICONWARNING or MB_OK);
721
end;
722

723
function IsExecutable(Ext: string): Boolean;
724
begin
725
  Result := Ext.EndsWith('.exe', True) or Ext.EndsWith('.bat', True);
726
end;
727

728
procedure ShellExecuteFL(const AWnd: HWND; const AOperation, AFileName: String;
729
  const AParameters: String = ''; const ADirectory: String = ''; const AShowCmd: Integer = SW_SHOWNORMAL);
730
var
731
  ExecInfo: TShellExecuteInfo;
732
  NeedUninitialize: Boolean;
733
begin
734
  Assert(AFileName <> '');
735

736
  NeedUninitialize := SUCCEEDED(CoInitializeEx(nil, COINIT_APARTMENTTHREADED or COINIT_DISABLE_OLE1DDE));
737
  try
738
    FillChar(ExecInfo, SizeOf(ExecInfo), 0);
739
    ExecInfo.cbSize := SizeOf(ExecInfo);
740

741
    ExecInfo.Wnd := AWnd;
742
    ExecInfo.lpVerb := Pointer(AOperation);
743
    ExecInfo.lpFile := PChar(AFileName);
744
    ExecInfo.lpParameters := Pointer(AParameters);
745
    ExecInfo.lpDirectory := Pointer(ADirectory);
746
    ExecInfo.nShow := AShowCmd;
747
    ExecInfo.fMask := SEE_MASK_NOASYNC { = SEE_MASK_FLAG_DDEWAIT для старых версий Delphi }
748
                   or SEE_MASK_FLAG_NO_UI;
749
    {$IFDEF UNICODE}
750
    // Необязательно, см. http://www.transl-gunsmoker.ru/2015/01/what-does-SEEMASKUNICODE-flag-in-ShellExecuteEx-actually-do.html
751
    ExecInfo.fMask := ExecInfo.fMask or SEE_MASK_UNICODE;
752
    {$ENDIF}
753

754
    {$WARN SYMBOL_PLATFORM OFF}
755
    Win32Check(ShellExecuteEx(@ExecInfo));
756
    {$WARN SYMBOL_PLATFORM ON}
757
  finally
758
    if NeedUninitialize then
759
      CoUninitialize;
760
  end;
761
end;
762

763
function CreateProcessFL(AExecutable, AParameters, APath: string; AWindowState,
764
  APriority: Integer; var AErrorCode: Integer): Boolean;
765
var
766
  pi: TProcessInformation;
767
  si: TStartupInfo;
768
begin
769
  ZeroMemory(@si, sizeof(si));
770
  si.cb := SizeOf(si);
771
  si.dwFlags := STARTF_USESHOWWINDOW;
772
  si.wShowWindow := AWindowState;
773
  ZeroMemory(@PI, SizeOf(PI));
774

775
  SetLastError(ERROR_INVALID_PARAMETER);
776
  {$WARN SYMBOL_PLATFORM OFF}
777
  Result := Winapi.Windows.CreateProcess(PChar(AExecutable), PChar(AParameters),
778
    nil, nil, false,
779
    APriority or CREATE_DEFAULT_ERROR_MODE or CREATE_UNICODE_ENVIRONMENT, nil,
780
    PChar(APath), si, pi);
781
  if Result then
782
    AErrorCode := 0
783
  else
784
    AErrorCode := GetLastError;
785
  {$WARN SYMBOL_PLATFORM ON}
786
  CloseHandle(PI.hThread);
787
  CloseHandle(PI.hProcess);
788
end;
789

790
procedure LaunchInExecutor(ALink: TLink; AMainHandle: HWND;
791
  ADroppedFile: string);
792
var
793
  Executor, Parameters: string;
794
  LinkStrings: TStringList;
795
begin
796
  Executor := GetAbsolutePath('%FL_DIR%\FLExecutor.exe');
797

798
  LinkStrings := TStringList.Create;
799
  try
800
    LinkToStrings(ALink, LinkStrings);
801
    LinkStrings.Delimiter := ';';
802
    LinkStrings.QuoteChar := '''';
803
    Parameters := AnsiQuotedStr(LinkStrings.DelimitedText, '"');
804
  finally
805
    LinkStrings.Free;
806
  end;
807

808
  Parameters := Parameters + ' ' + IntToStr(AMainHandle);
809
  Parameters := Parameters + ' ' + AnsiQuotedStr(Language.FileName, '"');
810
  Parameters := Parameters + ' ' + AnsiQuotedStr(ADroppedFile, '"');
811

812
  ShellExecuteFL(AMainHandle, '', Executor, Parameters);
813
end;
814

815
procedure ThreadLaunch(var ALink: TLink; AMainHandle: HWND; ADroppedFile: string);
816
const
817
  ERROR_ELEVATION_REQUIRED = 740;
818
var
819
  WinType, Prior, ErrorCode: integer;
820
  execparams, path, exec, params: string;
821

822
  function RunasCanBeUsed: Boolean;
823
  begin
824
    Result := Prior = NORMAL_PRIORITY_CLASS;
825
  end;
826

827
  procedure RunElevated;
828
  begin
829
    if RunasCanBeUsed then
830
      ShellExecuteFL(AMainHandle, 'runas', exec, execparams, path, WinType)
831
    else
832
      LaunchInExecutor(ALink, AMainHandle, ADroppedFile);
833
  end;
834

835
begin
836
  exec := GetAbsolutePath(ALink.exec);
837
  path := GetAbsolutePath(ALink.workdir);
838
  if path = '' then
839
    path := ExtractFilePath(exec);
840
  if not ALink.active then
841
    Exit;
842
  if (ALink.ques) and
843
    (RequestMessage(AMainHandle, Format(Language.Messages.RunProgram,
844
      [ExtractFileName(exec)])) = IDNO)
845
    then Exit;
846
  case ALink.wst of
847
    0: WinType := SW_SHOW;
848
    1: WinType := SW_SHOWMAXIMIZED;
849
    2: WinType := SW_SHOWMINIMIZED;
850
    3: WinType := SW_HIDE;
851
  end;
852
  if ALink.ltype = 0 then
853
  begin
854
    case ALink.pr of
855
      0: Prior := NORMAL_PRIORITY_CLASS;
856
      1: Prior := HIGH_PRIORITY_CLASS;
857
      2: Prior := IDLE_PRIORITY_CLASS;
858
      3: Prior := REALTIME_PRIORITY_CLASS;
859
      4: Prior := BELOW_NORMAL_PRIORITY_CLASS;
860
      5: Prior := ABOVE_NORMAL_PRIORITY_CLASS;
861
    end;
862
    if ADroppedFile <> '' then
863
      params := stringreplace(ALink.dropparams, '%1', ADroppedFile, [rfReplaceAll])
864
    else
865
      params := ALink.params;
866
    params := GetAbsolutePath(params);
867
    execparams := Format('"%s" %s', [exec, params]);
868
    if (ALink.IsAdmin or ALink.AsAdminPerm) and (not ParamStr(0).Contains('FLExecutor.exe')) then
869
      RunElevated
870
    else
871
      if not CreateProcessFL(exec, execparams, path, WinType, Prior, ErrorCode)
872
      then begin
873
        if ErrorCode = ERROR_ELEVATION_REQUIRED then
874
        begin
875
          ALink.IsAdmin := True;
876
          RunElevated;
877
        end
878
        else
879
          RaiseLastOSError(ErrorCode);
880
      end;
881
  end
882
  else
883
    ShellExecuteFL(AMainHandle, '', exec, '', path, WinType);
884
  if ALink.hide then
885
    PostMessage(AMainHandle, UM_HideMainForm, 0, 0);
886
end;
887

888
procedure NewProcess(ALink: TLink; AMainHandle: HWND; ALaunchID: Integer;
889
  ADroppedFile: string);
890
begin
891
  TThread.CreateAnonymousThread(procedure
892
    begin
893
      try
894
        ThreadLaunch(ALink, AMainHandle, ADroppedFile);
895
      except
896
        on E: EOSError do
897
          if not (e.ErrorCode = ERROR_CANCELLED) then
898
            WarningMessage(AMainHandle,
899
              StringReplace(e.Message, '%1', ExtractFileName(ALink.exec), [rfReplaceAll]));
900
        on E: Exception do
901
          WarningMessage(AMainHandle,
902
            StringReplace(e.Message, '%1', ExtractFileName(ALink.exec), [rfReplaceAll]));
903
      end;
904
      PostMessage(AMainHandle, UM_LaunchDone, ALink.IsAdmin.ToInteger, ALaunchID);
905
    end).Start;
906
end;
907

908
procedure ExecHelpFile(AMainHandle: HWND; AHelpFileName: string);
909
begin
910
  TThread.CreateAnonymousThread(procedure
911
    begin
912
      try
913
        ShellExecuteFL(AMainHandle, '', GetAbsolutePath(AHelpFileName), '',
914
          GetAbsolutePath(ExtractFilePath(AHelpFileName)), SW_SHOW);
915
      except
916
        on E: Exception do
917
          WarningMessage(AMainHandle,
918
            StringReplace(e.Message, '%1', ExtractFileName(AHelpFileName), [rfReplaceAll]));
919
      end;
920
    end).Start;
921
end;
922

923
function ExpandEnvironmentVariables(const AFileName: string): string;
924
var
925
  BuffSize: integer;
926
  Buffer: string;
927
begin
928
  Result := AFileName;
929
  SetLastError(0);
930
  BuffSize := ExpandEnvironmentStrings(PChar(AFileName), nil, 0);
931
  if BuffSize = 0 then
932
    RaiseLastOSError
933
  else
934
  begin
935
    SetLength(Buffer, BuffSize);
936
    if ExpandEnvironmentStrings(PChar(AFileName), PChar(Buffer), BuffSize) = 0 then
937
      RaiseLastOSError;
938
  end;
939
  Result := Copy(Buffer, 1, BuffSize - 1);
940
end;
941

942
procedure AddEnvironmentVariable(const AName, AValue: string);
943
begin
944
  SetLastError(0);
945
  if not SetEnvironmentVariable(PChar(AName),
946
    PChar(ExcludeTrailingPathDelimiter(AValue)))
947
  then
948
    RaiseLastOSError;
949
end;
950

951
const
952
  BUTTON_INI_SECTION = 'button';
953

954
procedure LinkToStrings(ALink: TLink; AStrings: TStrings);
955
var
956
  Ini: TMemIniFile;
957
begin
958
  Ini := TMemIniFile.Create('');
959
  try
960
    Ini.WriteString(BUTTON_INI_SECTION, 'version', FLVersion);
961
    Ini.WriteString(BUTTON_INI_SECTION, 'object', ALink.Exec);
962
    Ini.WriteString(BUTTON_INI_SECTION, 'workdir', ALink.WorkDir);
963
    Ini.WriteString(BUTTON_INI_SECTION, 'icon', ALink.Icon);
964
    Ini.WriteInteger(BUTTON_INI_SECTION, 'iconindex', ALink.IconIndex);
965
    Ini.WriteString(BUTTON_INI_SECTION, 'parameters', ALink.Params);
966
    Ini.WriteBool(BUTTON_INI_SECTION, 'dropfiles', ALink.DropFiles);
967
    Ini.WriteString(BUTTON_INI_SECTION, 'dropparameters', ALink.DropParams);
968
    Ini.WriteString(BUTTON_INI_SECTION, 'describe', ALink.Descr);
969
    Ini.WriteBool(BUTTON_INI_SECTION, 'question', ALink.Ques);
970
    Ini.WriteBool(BUTTON_INI_SECTION, 'hide', ALink.Hide);
971
    Ini.WriteInteger(BUTTON_INI_SECTION, 'priority', ALink.Pr);
972
    Ini.WriteInteger(BUTTON_INI_SECTION, 'windowstate', ALink.WSt);
973
    Ini.WriteBool(BUTTON_INI_SECTION, 'IsAdmin', ALink.IsAdmin);
974

975
    Ini.GetStrings(AStrings);
976
  finally
977
    Ini.Free;
978
  end;
979
end;
980

981
function StringsToLink(AStrings: TStrings): TLink;
982
var
983
  Ini: TMemIniFile;
984
  Ext: string;
985
begin
986
  Ini := TMemIniFile.Create('');
987
  try
988
    Ini.SetStrings(AStrings);
989

990
    Result.Exec := Ini.ReadString(BUTTON_INI_SECTION, 'object', '');
991
    Result.WorkDir := Ini.ReadString(BUTTON_INI_SECTION, 'workdir', '');
992
    Result.Icon := Ini.ReadString(BUTTON_INI_SECTION, 'icon', '');
993
    Result.IconIndex := Ini.ReadInteger(BUTTON_INI_SECTION, 'iconindex', 0);
994
    Result.Params := Ini.ReadString(BUTTON_INI_SECTION, 'parameters', '');
995
    Result.DropFiles := Ini.ReadBool(BUTTON_INI_SECTION, 'dropfiles', false);
996
    Result.DropParams := Ini.ReadString(BUTTON_INI_SECTION, 'dropparameters', '');
997
    Result.Descr := Ini.ReadString(BUTTON_INI_SECTION, 'describe', '');
998
    Result.Ques := Ini.ReadBool(BUTTON_INI_SECTION, 'question', false);
999
    Result.Hide := Ini.ReadBool(BUTTON_INI_SECTION, 'hide', false);
1000
    Result.Pr := Ini.ReadInteger(BUTTON_INI_SECTION, 'priority', 0);
1001
    Result.WSt := Ini.ReadInteger(BUTTON_INI_SECTION, 'windowstate', 0);
1002
    Result.IsAdmin := Ini.ReadBool(BUTTON_INI_SECTION, 'IsAdmin', False);
1003

1004
    Result.Active := True;
1005
    Ext := ExtractFileExt(Result.Exec).ToLower;
1006
    if IsExecutable(Ext) then
1007
      Result.LType := 0
1008
    else
1009
      Result.LType := 1;
1010
  finally
1011
    Ini.Free;
1012
  end;
1013
end;
1014

1015
// Modified version of http://www.sql.ru/forum/actualutils.aspx?action=gotomsg&tid=1160302&msg=17742423
1016
function GetSystemIcon(AIconID: PChar; ALarge: Boolean; ASz: PSize): HICON;
1017
var
1018
  IcoWidth: Integer;
1019
  IcoHeight: Integer;
1020
  LoadIconWithScaleDown: function(hinst: HMODULE; pszName: PWideChar; cx, cy: Integer; out Ico: HICON): HRESULT; stdcall;
1021

1022
  procedure SetStandartSize;
1023
  begin
1024
    if ALarge then
1025
    begin
1026
      IcoWidth := GetSystemMetrics(SM_CXICON);
1027
      IcoHeight := GetSystemMetrics(SM_CYICON);
1028
    end
1029
    else
1030
    begin
1031
      IcoWidth := GetSystemMetrics(SM_CXSMICON);
1032
      IcoHeight := GetSystemMetrics(SM_CYSMICON);
1033
    end;
1034
  end;
1035

1036
begin
1037
  if Assigned(ASz) then
1038
  begin
1039
    IcoWidth := ASz.cx;
1040
    IcoHeight := ASz.cy;
1041
  end
1042
  else
1043
    SetStandartSize;
1044

1045
  LoadIconWithScaleDown := GetProcAddress(GetModuleHandle(comctl32), 'LoadIconWithScaleDown'); // Do Not Localize
1046
  if Assigned(LoadIconWithScaleDown) then
1047
  begin
1048
    if Failed(LoadIconWithScaleDown(0, AIconID, IcoWidth, IcoHeight, Result)) then
1049
      Result := 0;
1050
  end
1051
  else
1052
    Result := 0;
1053

1054
  try
1055
    if Result = 0 then
1056
    begin
1057
      SetStandartSize;
1058
      Result := LoadImage(0, AIconID, IMAGE_ICON, IcoWidth, IcoHeight, LR_DEFAULTCOLOR or LR_SHARED);
1059
      if Result = 0 then
1060
        RaiseLastOSError;
1061
      Result := CopyIcon(Result);
1062
      if Result = 0 then
1063
        RaiseLastOSError;
1064
    end;
1065
  except
1066
    if Result <> 0 then
1067
      DestroyIcon(Result);
1068
    raise;
1069
  end;
1070

1071
  if Assigned(ASz) then
1072
  begin
1073
    ASz.cx := IcoWidth;
1074
    ASz.cy := IcoHeight;
1075
  end;
1076
end;
1077

1078
procedure DrawShieldIcon(ACanvas: TCanvas; APosition: TPoint; ASize: TSize);
1079
var
1080
  IconHandle: HICON;
1081
begin
1082
  IconHandle := GetSystemIcon(IDI_SHIELD, False, @ASize);
1083
  DrawIconEx(ACanvas.Handle, APosition.X, APosition.Y, IconHandle, ASize.cx,
1084
    ASize.cy, 0, 0, DI_NORMAL);
1085
end;
1086

1087
procedure InitEnvironment;
1088
var
1089
  sini: TIniFile;
1090
begin
1091
  fl_dir := ExtractFilePath(ParamStr(0));
1092
  fl_root := IncludeTrailingPathDelimiter(ExtractFileDrive(fl_dir));
1093
  //Считываем файл первичных настроек для определения режима работы программы
1094
  //и места хранения настроек
1095
  sini := TIniFile.Create(fl_dir + 'UseProfile.ini');
1096
  try
1097
    SettingsMode := sini.ReadInteger('general', 'settingsmode', 0);
1098
    if SettingsMode > 2 then SettingsMode := 0;
1099
    if (SettingsMode = 0) then
1100
    begin
1101
      fl_WorkDir := GetSpecialDir(CSIDL_APPDATA) + 'FreeLaunch\';
1102
      if not DirectoryExists(fl_WorkDir) then
1103
        CreateDir(fl_WorkDir);
1104
    end
1105
    else
1106
      fl_WorkDir := fl_dir;
1107
  finally
1108
    sini.Free;
1109
  end;
1110
  {*--Заполняем переменные FL_*--*}
1111
  AddEnvironmentVariable('FL_DIR', FL_DIR);
1112
  AddEnvironmentVariable('FL_ROOT', FL_ROOT);
1113
  AddEnvironmentVariable('FL_CONFIG', fl_WorkDir);
1114
end;
1115

1116
function IsPortable: Boolean;
1117
begin
1118
  Result := SettingsMode = 2;
1119
end;
1120

1121
function PathToPortable(APath: string): string;
1122
var
1123
  FullPath: string;
1124
begin
1125
  Result := APath;
1126
  if APath = '' then Exit;
1127
  FullPath := TPath.GetFullPath(GetAbsolutePath(APath));
1128
  if ContainsText(FullPath, fl_dir) then
1129
    Result := ReplaceText(FullPath, fl_dir, '%FL_DIR%\')
1130
  else
1131
    if ContainsText(FullPath, fl_root) then
1132
      Result := ReplaceText(FullPath, fl_root, '%FL_ROOT%\');
1133
end;
1134

1135
function WinThemeDetect: string;
1136
const
1137
  DarkKey = 'Software\Microsoft\Windows\CurrentVersion\Themes\Personalize\';
1138
  DarkValue = 'AppsUseLightTheme';
1139
var
1140
  rval: Integer;
1141
  reg: TRegistry;
1142
begin
1143
  Result := FLThemes[0].Name;
1144
  reg := TRegistry.Create(KEY_READ);
1145
  try
1146
    reg.RootKey := HKEY_CURRENT_USER;
1147
    if TOSVersion.Check(10) then begin
1148
      if not reg.KeyExists(DarkKey) then Exit;
1149
      if not reg.OpenKeyReadOnly(DarkKey) then Exit;
1150
      if not reg.ValueExists(DarkValue) then Exit;
1151
      rval := reg.ReadInteger(DarkValue) + 1;
1152
      if not (rval in [0..2]) then rval := 0;
1153
      Result := FLThemes[rval].Name;
1154
    end;
1155
  finally
1156
    reg.CloseKey;
1157
    reg.Free;
1158
  end;
1159
end;
1160

1161
procedure SetAppTheme(AName: string);
1162
begin
1163
  TStyleManager.TrySetStyle(AName, False);
1164
end;
1165

1166
function GetAppTheme: string;
1167
begin
1168
  Result := TStyleManager.ActiveStyle.Name;
1169
end;
1170

1171
function GetAppThemeIndex(AName: string): Integer;
1172
var
1173
  I: Integer;
1174
begin
1175
  Result := 0;
1176
  for I := Low(FLThemes) to High(FLThemes) do
1177
    if FLThemes[I].Name = AName then begin
1178
      Result := I;
1179
      Exit;
1180
    end;
1181
end;
1182

1183
function FindSysUserDefLangFile: string;
1184
var
1185
  CurrLCID: Word;
1186
  sRec: TSearchRec;
1187
  Dir: string;
1188
  lngfile: TIniFile;
1189
begin
1190
  Result := 'english.lng'; //default language
1191
  // get current user language code ID. See the for LCID: https://learn.microsoft.com/ru-ru/openspecs/windows_protocols/ms-lcid/
1192
  CurrLCID := GetUserDefaultUILanguage;
1193
  Dir := ExtractFilePath(ParamStr(0)) + 'languages\';
1194
  if FindFirst(Dir + '*.*', faAnyFile, sRec) = 0 then repeat
1195
    if (sRec.Name = '.') or (sRec.Name = '..') then Continue;
1196
    if ExtractFileExt(sRec.Name).ToLower = '.lng' then begin
1197
      lngfile := TIniFile.Create(Dir + sRec.Name);
1198
      try
1199
        if lngfile.ReadInteger('information','langid', - 1) = CurrLCID
1200
        then begin
1201
          Result := sRec.Name;
1202
          FindClose(sRec);
1203
          Exit;
1204
        end;
1205
      finally
1206
        lngfile.Free;
1207
      end;
1208
    end;
1209
  until FindNext(sRec) <> 0;
1210
  FindClose(sRec);
1211
end;
1212

1213
end.
1214