forked from jrsoftware/issrc
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathCompFunc.pas
849 lines (763 loc) · 26.9 KB
/
CompFunc.pas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
unit CompFunc;
{
Inno Setup
Copyright (C) 1997-2024 Jordan Russell
Portions by Martijn Laan
For conditions of distribution and use, see LICENSE.TXT.
Additional Compiler IDE functions
}
interface
uses
Windows,
Classes, Forms, Dialogs, Menus, Controls, StdCtrls,
ScintEdit, CompScintEdit, ModernColors;
const
MRUListMaxCount = 10;
type
TMRUItemCompareProc = function(const S1, S2: String): Integer;
TAddLinesPrefix = (alpNone, alpTimestamp, alpCountdown);
TKeyMappingType = (kmtDelphi, kmtVisualStudio);
procedure InitFormFont(Form: TForm);
procedure SetControlWindowTheme(const WinControl: TWinControl; const Dark: Boolean);
procedure InitFormThemeInit(const ATheme: TTheme);
procedure InitFormTheme(Form: TForm);
function GetDisplayFilename(const Filename: String): String;
function GetFileTitle(const Filename: String): String;
function GetCleanFileNameOfFile(const Filename: String): String;
function GetLastWriteTimeOfFile(const Filename: String;
LastWriteTime: PFileTime): Boolean;
procedure AddFileToRecentDocs(const Filename: String);
function GenerateGuid: String;
function ISPPInstalled: Boolean;
function IsISPPBuiltins(const Filename: String): Boolean;
function ISCryptInstalled: Boolean;
function WindowsVersionAtLeast(const AMajor, AMinor: Byte; const ABuild: Word = 0): Boolean;
function IsWindows10: Boolean;
function IsWindows11: Boolean;
function GetDefaultThemeType: TThemeType;
function GetDefaultKeyMappingType: TKeyMappingType;
function GetDefaultMemoKeyMappingType: TCompScintKeyMappingType;
procedure OpenDonateSite;
procedure OpenMailingListSite;
procedure ClearMRUList(const MRUList: TStringList; const Section: String);
procedure ReadMRUList(const MRUList: TStringList; const Section, Ident: String);
procedure ModifyMRUList(const MRUList: TStringList; const Section, Ident: String;
const AItem: String; const AddNewItem: Boolean; CompareProc: TMRUItemCompareProc);
procedure LoadKnownIncludedAndHiddenFiles(const AFilename: String; const IncludedFiles, HiddenFiles: TStringList);
procedure SaveKnownIncludedAndHiddenFiles(const AFilename: String; const IncludedFiles, HiddenFiles: TStringList);
procedure DeleteKnownIncludedAndHiddenFiles(const AFilename: String);
procedure LoadBreakPointLines(const AFilename: String; const BreakPointLines: TStringList);
procedure SaveBreakPointLines(const AFilename: String; const BreakPointLines: TStringList);
procedure DeleteBreakPointLines(const AFilename: String);
function NewShortCutToText(const ShortCut: TShortCut): String;
procedure SetFakeShortCutText(const MenuItem: TMenuItem; const S: String);
procedure SetFakeShortCut(const MenuItem: TMenuItem; const Key: Word;
const Shift: TShiftState); overload;
procedure SetFakeShortCut(const MenuItem: TMenuItem; const ShortCut: TShortCut); overload;
procedure SaveTextToFile(const Filename: String;
const S: String; const SaveEncoding: TSaveEncoding);
procedure AddLines(const ListBox: TListBox; const S: String; const AObject: TObject; const LineBreaks: Boolean; const Prefix: TAddLinesPrefix; const PrefixParam: Cardinal);
procedure SetLowPriority(ALowPriority: Boolean; var SavePriorityClass: DWORD);
function GetHelpFile: String;
function FindOptionsToSearchOptions(const FindOptions: TFindOptions): TScintFindOptions;
procedure StartAddRemovePrograms;
function GetSourcePath(const AFilename: String): String;
function ReadScriptLines(const ALines: TStringList; const ReadFromFile: Boolean;
const ReadFromFileFilename: String; const NotReadFromFileMemo: TScintEdit): Integer;
function CreateBitmapInfo(const Width, Height, BitCount: Integer): TBitmapInfo;
function GetWordOccurrenceFindOptions: TScintFindOptions;
function GetSelTextOccurrenceFindOptions: TScintFindOptions;
function GetPreferredMemoFont: String;
implementation
uses
ActiveX, ShlObj, ShellApi, CommDlg, SysUtils, IOUtils,
Messages, DwmApi, Consts,
CmnFunc2, PathFunc, FileClass, NewUxTheme,
CompForm, CompMsgs2, CompTypes;
procedure InitFormFont(Form: TForm);
var
FontName: String;
Metrics: TNonClientMetrics;
begin
begin
Metrics.cbSize := SizeOf(Metrics);
if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, SizeOf(Metrics),
@Metrics, 0) then
FontName := Metrics.lfMessageFont.lfFaceName;
{ Only allow fonts that we know will fit the text correctly }
if not SameText(FontName, 'Microsoft Sans Serif') and
not SameText(FontName, 'Segoe UI') then
FontName := 'Tahoma';
end;
Form.Font.Name := FontName;
Form.Font.Size := 8;
end;
procedure SetControlWindowTheme(const WinControl: TWinControl; const Dark: Boolean);
begin
if UseThemes then begin
if Dark then
SetWindowTheme(WinControl.Handle, 'DarkMode_Explorer', nil)
else
SetWindowTheme(WinControl.Handle, nil, nil);
end;
end;
var
FormTheme: TTheme;
procedure InitFormThemeInit(const ATheme: TTheme);
begin
FormTheme := ATheme;
end;
procedure InitFormTheme(Form: TForm);
procedure InitListBoxDarkTheme(const ListBox: TListBox);
begin
ListBox.Font.Color := FormTheme.Colors[tcFore];
ListBox.Color := FormTheme.Colors[tcBack];
ListBox.Invalidate;
SetControlWindowTheme(ListBox, FormTheme.Dark);
end;
procedure InitWinControlTheme(const ParentControl: TWinControl);
begin
for var I := 0 to ParentControl.ControlCount-1 do begin
var Control := ParentControl.Controls[I];
if Control is TListBox then
InitListBoxDarkTheme(Control as TListBox)
else if Control is TWinControl then
InitWinControlTheme(Control as TWinControl);
end;
end;
begin
if (Form = CompileForm) or FormTheme.Dark then begin
Form.Color := FormTheme.Colors[tcBack];
{ Based on https://learn.microsoft.com/en-us/windows/apps/desktop/modernize/apply-windows-themes
Unlike this article we check for Windows 10 Version 2004 because that's the first version
that introduced DWMWA_USE_IMMERSIVE_DARK_MODE as 20 (the now documented value) instead of 19 }
if WindowsVersionAtLeast(10, 0, 19041) then begin
const DWMWA_USE_IMMERSIVE_DARK_MODE = 20;
var value: BOOL := FormTheme.Dark;
DwmSetWindowAttribute(Form.Handle, DWMWA_USE_IMMERSIVE_DARK_MODE, @value, SizeOf(value));
end;
InitWinControlTheme(Form);
end;
end;
function GetDisplayFilename(const Filename: String): String;
var
Buf: array[0..MAX_PATH-1] of Char;
begin
if CommDlg.GetFileTitle(PChar(Filename), Buf, SizeOf(Buf) div SizeOf(Buf[0])) = 0 then
Result := Buf
else
Result := Filename;
end;
function GetFileTitle(const Filename: String): String;
begin
if Filename = '' then
Result := 'Untitled'
else
Result := Filename;
end;
function GetCleanFileNameOfFile(const Filename: String): String;
begin
var Files := TDirectory.GetFiles(PathExtractDir(Filename), PathExtractName(Filename));
if Length(Files) = 1 then
Result := Files[0]
else
Result := Filename;
end;
function GetLastWriteTimeOfFile(const Filename: String;
LastWriteTime: PFileTime): Boolean;
var
H: THandle;
begin
H := CreateFile(PChar(Filename), 0, FILE_SHARE_READ or FILE_SHARE_WRITE,
nil, OPEN_EXISTING, 0, 0);
if H <> INVALID_HANDLE_VALUE then begin
Result := GetFileTime(H, nil, nil, LastWriteTime);
CloseHandle(H);
end
else
Result := False;
end;
procedure AddFileToRecentDocs(const Filename: String);
{ Notifies the shell that a document has been opened. This will
add the file to the Recent section of the app's Jump List.
It is only necessary to call this function when the shell is unaware that
a file is being opened. Files opened through Explorer or common dialogs get
added to the Jump List automatically. }
begin
SHAddToRecentDocs(SHARD_PATHW, PChar(Filename));
end;
function GenerateGuid: String;
var
Guid: TGUID;
P: PWideChar;
begin
if CoCreateGuid(Guid) <> S_OK then
raise Exception.Create('CoCreateGuid failed');
if StringFromCLSID(Guid, P) <> S_OK then
raise Exception.Create('StringFromCLSID failed');
try
Result := P;
finally
CoTaskMemFree(P);
end;
end;
function ISPPInstalled: Boolean;
begin
Result := NewFileExists(PathExtractPath(NewParamStr(0)) + 'ISPP.dll');
end;
function IsISPPBuiltins(const Filename: String): Boolean;
begin
Result := PathCompare(PathExtractName(Filename), 'ISPPBuiltins.iss') = 0;
end;
function ISCryptInstalled: Boolean;
begin
Result := NewFileExists(PathExtractPath(NewParamStr(0)) + 'iscrypt.dll');
end;
var
WindowsVersion: Cardinal;
function WindowsVersionAtLeast(const AMajor, AMinor: Byte; const ABuild: Word): Boolean;
begin
Result := WindowsVersion >= Cardinal((AMajor shl 24) or (AMinor shl 16) or ABuild);
end;
function IsWindows10: Boolean;
begin
Result := WindowsVersionAtLeast(10, 0);
end;
function IsWindows11: Boolean;
begin
Result := WindowsVersionAtLeast(10, 0, 22000);
end;
function GetDefaultThemeType: TThemeType;
var
K: HKEY;
Size, AppsUseLightTheme: DWORD;
begin
Result := ttModernLight;
if IsWindows10 and (RegOpenKeyExView(rvDefault, HKEY_CURRENT_USER, 'SOFTWARE\Microsoft\Windows\CurrentVersion\Themes\Personalize', 0, KEY_QUERY_VALUE, K) = ERROR_SUCCESS) then begin
Size := SizeOf(AppsUseLightTheme);
if (RegQueryValueEx(K, 'AppsUseLightTheme', nil, nil, @AppsUseLightTheme, @Size) = ERROR_SUCCESS) and (AppsUseLightTheme = 0) then
Result := ttModernDark;
RegCloseKey(K);
end;
end;
function GetDefaultKeyMappingType: TKeyMappingType;
begin
Result := kmtDelphi;
end;
function GetDefaultMemoKeyMappingType: TCompScintKeyMappingType;
begin
Result := kmtDefault;
end;
procedure OpenDonateSite;
begin
ShellExecute(Application.Handle, 'open', 'https://jrsoftware.org/isdonate.php', nil,
nil, SW_SHOWNORMAL);
end;
procedure OpenMailingListSite;
begin
ShellExecute(Application.Handle, 'open', 'https://jrsoftware.org/ismail.php', nil,
nil, SW_SHOWNORMAL);
end;
procedure ClearMRUList(const MRUList: TStringList; const Section: String);
var
Ini: TConfigIniFile;
begin
Ini := TConfigIniFile.Create;
try
MRUList.Clear;
Ini.EraseSection(Section);
finally
Ini.Free;
end;
end;
procedure ReadMRUList(const MRUList: TStringList; const Section, Ident: String);
{ Loads a list of MRU items from the registry }
var
Ini: TConfigIniFile;
I: Integer;
S: String;
begin
Ini := TConfigIniFile.Create;
try
MRUList.Clear;
for I := 0 to MRUListMaxCount-1 do begin
S := Ini.ReadString(Section, Ident + IntToStr(I), '');
if S <> '' then MRUList.Add(S);
end;
finally
Ini.Free;
end;
end;
procedure ModifyMRUList(const MRUList: TStringList; const Section, Ident: String;
const AItem: String; const AddNewItem: Boolean; CompareProc: TMRUItemCompareProc);
var
I: Integer;
Ini: TConfigIniFile;
S: String;
begin
I := 0;
while I < MRUList.Count do begin
if CompareProc(MRUList[I], AItem) = 0 then
MRUList.Delete(I)
else
Inc(I);
end;
if AddNewItem then
MRUList.Insert(0, AItem);
while MRUList.Count > MRUListMaxCount do
MRUList.Delete(MRUList.Count-1);
{ Save new MRU items }
Ini := TConfigIniFile.Create;
try
{ MRU list }
for I := 0 to MRUListMaxCount-1 do begin
if I < MRUList.Count then
S := MRUList[I]
else
S := '';
Ini.WriteString(Section, Ident + IntToStr(I), S);
end;
finally
Ini.Free;
end;
end;
procedure LoadConfigIniList(const AIni: TConfigIniFile; const ASection, AIdent: String;
const AList: TStringList; const ADelimiter: Char);
begin
if ASection = '' then
raise Exception.Create('ASection must be set');
var OldDelimiter := AList.Delimiter;
AList.Delimiter := ADelimiter;
try
AList.DelimitedText := AIni.ReadString(ASection, AIdent, '');
finally
AList.Delimiter := OldDelimiter;
end;
end;
procedure DeleteConfigIniList(const AIni: TConfigIniFile; const ASection, AIdent: String);
begin
if ASection = '' then
raise Exception.Create('ASection must be set');
AIni.DeleteKey(ASection, AIdent);
end;
procedure SaveConfigIniList(const AIni: TConfigIniFile; const ASection, AIdent: String;
const AList: TStringList; const ADelimiter: Char);
begin
if AList.Count = 0 then begin
DeleteConfigIniList(AIni, ASection, AIdent);
Exit;
end;
if ASection = '' then
raise Exception.Create('ASection must be set');
var OldDelimiter := AList.Delimiter;
AList.Delimiter := ADelimiter;
try
AIni.WriteString(ASection, AIdent, AList.DelimitedText);
finally
AList.Delimiter := OldDelimiter;
end;
end;
procedure LoadKnownIncludedAndHiddenFiles(const AFilename: String; const IncludedFiles, HiddenFiles: TStringList);
begin
var Ini := TConfigIniFile.Create;
try
LoadConfigIniList(Ini, 'IncludedFilesHistory', AFilename, IncludedFiles, '*');
LoadConfigIniList(Ini, 'HiddenFilesHistory', AFilename, HiddenFiles, '*');
finally
Ini.Free;
end;
end;
procedure SaveKnownIncludedAndHiddenFiles(const AFilename: String; const IncludedFiles, HiddenFiles: TStringList);
begin
var Ini := TConfigIniFile.Create;
try
SaveConfigIniList(Ini, 'IncludedFilesHistory', AFilename, IncludedFiles, '*');
SaveConfigIniList(Ini, 'HiddenFilesHistory', AFilename, HiddenFiles, '*');
finally
Ini.Free;
end;
end;
procedure DeleteKnownIncludedAndHiddenFiles(const AFilename: String);
begin
var Ini := TConfigIniFile.Create;
try
DeleteConfigIniList(Ini, 'IncludedFilesHistory', AFilename);
DeleteConfigIniList(Ini, 'HiddenFilesHistory', AFilename);
finally
Ini.Free;
end;
end;
procedure LoadBreakPointLines(const AFilename: String; const BreakPointLines: TStringList);
begin
var Ini := TConfigIniFile.Create;
try
LoadConfigIniList(Ini, 'BreakPointLines', AFilename, BreakPointLines, ',');
finally
Ini.Free;
end;
end;
procedure SaveBreakPointLines(const AFilename: String; const BreakPointLines: TStringList);
begin
var Ini := TConfigIniFile.Create;
try
SaveConfigIniList(Ini, 'BreakPointLines', AFilename, BreakPointLines, ',');
finally
Ini.Free;
end;
end;
procedure DeleteBreakPointLines(const AFilename: String);
begin
var Ini := TConfigIniFile.Create;
try
DeleteConfigIniList(Ini, 'BreakPointLines', AFilename);
finally
Ini.Free;
end;
end;
function NewShortCutToText(const ShortCut: TShortCut): String;
{ This function is better than Delphi's ShortCutToText function because it works
for dead keys. A dead key is a key which waits for the user to press another
key so it can be combined. For example `+e=è. Pressing space after a dead key
produces the dead key char itself. For example `+space=`. }
const
{ List of chars ShortCutToText knows about and doesn't rely on Win32's
GetKeyNameText for, taken from Vcl.Menus.pas }
OKKeys = [$08, $09, $0D, $1B, $20..$28, $2D..$2E, $30..$39, $41..$5A, $70..$87];
begin
Result := '';
var Key := LoByte(Word(ShortCut));
if not (Key in OKKeys) then begin
{ ShortCutToText will use Win32's GetKeyNameText for this key and if it's
a dead key this gives long names like 'ACCENT CIRCONFLEXE' instead of a
short name like '^'. Long names are not what we want so handle these dead
keys ourselves and use ToUnicode instead of GetKeyNameText to find the
short name. For non-dead keys we always call ShortCutToText even if
ToUnicode might work as well. }
var ScanCode := MapVirtualKey(Key, MAPVK_VK_TO_VSC);
if ScanCode <> 0 then begin
var KeyboardState: TKeyboardState;
GetKeyboardState(KeyboardState);
const TempSize = 64; { Same as Vcl.Touch.Keyboard.pas }
var TempStr: String;
SetLength(TempStr, TempSize);
ZeroMemory(@TempStr[1], TempSize * SizeOf(Char));
var Size := ToUnicode(Key, ScanCode, KeyboardState, @TempStr[1], TempSize, 0);
if Size = -1 then begin
{ This was a dead key, now stored in TempStr. Add space to get the dead
key char itself. }
ScanCode := MapVirtualKey(VK_SPACE, MAPVK_VK_TO_VSC);
if ScanCode <> 0 then begin
Size := ToUnicode(VK_SPACE, ScanCode, KeyboardState, @TempStr[1], TempSize, 0);
if Size = 1 then begin
var Name := TempStr[1];
if ShortCut and scShift <> 0 then Result := Result + SmkcShift;
if ShortCut and scCtrl <> 0 then Result := Result + SmkcCtrl;
if ShortCut and scAlt <> 0 then Result := Result + SmkcAlt;
Result := Result + Name;
end;
end;
end;
end else begin
{ This virtual key has no scan code meaning it's impossible to enter with
the current keyboard layout (for example French AZERTY + VK_OEM_MINUS).
We can just exit because calling ShortCutToText is pointless. }
Exit;
end;
end;
if Result = '' then
Result := ShortCutToText(ShortCut);
{ Example CompForm test code:
SetFakeShortCut(HDonate, ShortCut(VK_OEM_1, []));
SetFakeShortCut(HShortcutsDoc, ShortCut(VK_OEM_PLUS, []));
SetFakeShortCut(HDoc, ShortCut(VK_OEM_COMMA, []));
SetFakeShortCut(HExamples, ShortCut(VK_OEM_MINUS, []));
SetFakeShortCut(HFaq, ShortCut(VK_OEM_PERIOD, []));
SetFakeShortCut(HMailingList, ShortCut(VK_OEM_2, []));
SetFakeShortCut(HWhatsNew, ShortCut(VK_OEM_3, []));
SetFakeShortCut(HWebsite, ShortCut(VK_OEM_4, []));
SetFakeShortCut(HISPPDoc, ShortCut(VK_OEM_5, []));
SetFakeShortCut(HAbout, ShortCut(VK_OEM_6, []));
SetFakeShortCut(TAddRemovePrograms, ShortCut(VK_OEM_7, []));
Without our dead key handling this produces for example:
-US International + VK_OEM_3: "GRAVE"
-French AZERTY + VK_OEM_7: "ACCENT CIRCONFLEXE"
To add a keyboard layout follow the instructions at
https://www.thewindowsclub.com/add-or-remove-keyboard-layout-in-windows-11
and then switch to the language using the task bar's language bar.
Also see https://code.visualstudio.com/docs/getstarted/keybindings#_keyboard-layouts }
end;
procedure SetFakeShortCutText(const MenuItem: TMenuItem; const S: String);
begin
var Caption := MenuItem.Caption;
var P := Pos(#9, Caption);
if P <> 0 then
Delete(Caption, P, MaxInt);
if S <> '' then
MenuItem.Caption := Caption + #9 + S
else
MenuItem.Caption := Caption;
end;
procedure SetFakeShortCut(const MenuItem: TMenuItem; const Key: Word;
const Shift: TShiftState);
begin
SetFakeShortCut(MenuItem, ShortCut(Key, Shift));
end;
procedure SetFakeShortCut(const MenuItem: TMenuItem; const ShortCut: TShortCut);
begin
SetFakeShortCutText(MenuItem, NewShortCutToText(ShortCut));
end;
procedure SaveTextToFile(const Filename: String;
const S: String; const SaveEncoding: TSaveEncoding);
var
AnsiMode: Boolean;
AnsiStr: AnsiString;
F: TTextFileWriter;
begin
AnsiMode := False;
if SaveEncoding = seAuto then begin
AnsiStr := AnsiString(S);
if S = String(AnsiStr) then
AnsiMode := True;
end;
F := TTextFileWriter.Create(Filename, fdCreateAlways, faWrite, fsNone);
try
if AnsiMode then
F.WriteAnsi(AnsiStr)
else begin
F.UTF8WithoutBOM := SaveEncoding <> seUTF8WithBOM;
F.Write(S);
end;
finally
F.Free;
end;
end;
procedure AddLines(const ListBox: TListBox; const S: String; const AObject: TObject; const LineBreaks: Boolean; const Prefix: TAddLinesPrefix; const PrefixParam: Cardinal);
var
ST: TSystemTime;
LineNumber: Cardinal;
procedure AddLine(S: String);
var
TimestampPrefixTab: Boolean;
DC: HDC;
Size: TSize;
begin
TimestampPrefixTab := False;
case Prefix of
alpTimestamp:
begin
if LineNumber = 0 then begin
{ Don't forget about ListBox's DrawItem if you change the format of the following timestamp. }
Insert(Format('[%.2u%s%.2u%s%.2u%s%.3u] ', [ST.wHour, FormatSettings.TimeSeparator,
ST.wMinute, FormatSettings.TimeSeparator, ST.wSecond, FormatSettings.DecimalSeparator,
ST.wMilliseconds]), S, 1);
end else begin
Insert(#9, S, 1); { Not actually painted - just for Ctrl+C }
TimestampPrefixTab := True;
end;
end;
alpCountdown:
begin
Insert(Format('[%.2d] ', [PrefixParam-LineNumber]), S, 1);
end;
end;
try
ListBox.TopIndex := ListBox.Items.AddObject(S, AObject);
except
on EOutOfResources do begin
ListBox.Clear;
SendMessage(ListBox.Handle, LB_SETHORIZONTALEXTENT, 0, 0);
ListBox.Items.Add(SCompilerStatusReset);
ListBox.TopIndex := ListBox.Items.AddObject(S, AObject);
end;
end;
DC := GetDC(0);
try
SelectObject(DC, ListBox.Font.Handle);
if TimestampPrefixTab then
GetTextExtentPoint(DC, PChar(S)+1, Length(S)-1, Size)
else
GetTextExtentPoint(DC, PChar(S), Length(S), Size);
finally
ReleaseDC(0, DC);
end;
Inc(Size.cx, 5);
if TimestampPrefixTab then
Inc(Size.cx, PrefixParam);
if Size.cx > SendMessage(ListBox.Handle, LB_GETHORIZONTALEXTENT, 0, 0) then
SendMessage(ListBox.Handle, LB_SETHORIZONTALEXTENT, Size.cx, 0);
Inc(LineNumber);
end;
var
LineStart, I: Integer;
LastWasCR: Boolean;
begin
GetLocalTime(ST);
if LineBreaks then begin
LineNumber := 0;
LineStart := 1;
LastWasCR := False;
{ Call AddLine for each line. CR, LF, and CRLF line breaks are supported. }
for I := 1 to Length(S) do begin
if S[I] = #13 then begin
AddLine(Copy(S, LineStart, I - LineStart));
LineStart := I + 1;
LastWasCR := True;
end
else begin
if S[I] = #10 then begin
if not LastWasCR then
AddLine(Copy(S, LineStart, I - LineStart));
LineStart := I + 1;
end;
LastWasCR := False;
end;
end;
AddLine(Copy(S, LineStart, Maxint));
end else
AddLine(S);
end;
procedure SetLowPriority(ALowPriority: Boolean; var SavePriorityClass: DWORD);
begin
if ALowPriority then begin
{ Save current priority and change to 'low' }
if SavePriorityClass = 0 then
SavePriorityClass := GetPriorityClass(GetCurrentProcess);
SetPriorityClass(GetCurrentProcess, IDLE_PRIORITY_CLASS);
end
else begin
{ Restore original priority }
if SavePriorityClass <> 0 then begin
SetPriorityClass(GetCurrentProcess, SavePriorityClass);
SavePriorityClass := 0;
end;
end;
end;
function GetHelpFile: String;
begin
Result := PathExtractPath(NewParamStr(0)) + 'isetup.chm';
end;
function FindOptionsToSearchOptions(const FindOptions: TFindOptions): TScintFindOptions;
begin
Result := [];
if frMatchCase in FindOptions then
Include(Result, sfoMatchCase);
if frWholeWord in FindOptions then
Include(Result, sfoWholeWord);
end;
procedure StartAddRemovePrograms;
var
Dir: String;
Wow64DisableWow64FsRedirectionFunc: function(var OldValue: Pointer): BOOL; stdcall;
Wow64RevertWow64FsRedirectionFunc: function(OldValue: Pointer): BOOL; stdcall;
RedirDisabled: Boolean;
RedirOldValue: Pointer;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin
Dir := GetSystemDir;
FillChar(StartupInfo, SizeOf(StartupInfo), 0);
StartupInfo.cb := SizeOf(StartupInfo);
{ Have to disable file system redirection because the 32-bit version of
appwiz.cpl is buggy on XP x64 RC2 -- it doesn't show any Change/Remove
buttons on 64-bit MSI entries, and it doesn't list non-MSI 64-bit apps
at all. }
Wow64DisableWow64FsRedirectionFunc := GetProcAddress(GetModuleHandle(kernel32),
'Wow64DisableWow64FsRedirection');
Wow64RevertWow64FsRedirectionFunc := GetProcAddress(GetModuleHandle(kernel32),
'Wow64RevertWow64FsRedirection');
RedirDisabled := Assigned(Wow64DisableWow64FsRedirectionFunc) and
Assigned(Wow64RevertWow64FsRedirectionFunc) and
Wow64DisableWow64FsRedirectionFunc(RedirOldValue);
try
Win32Check(CreateProcess(nil, PChar('"' + AddBackslash(Dir) + 'control.exe" appwiz.cpl'),
nil, nil, False, 0, nil, PChar(Dir), StartupInfo, ProcessInfo));
finally
if RedirDisabled then
Wow64RevertWow64FsRedirectionFunc(RedirOldValue);
end;
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
end;
function GetSourcePath(const AFilename: String): String;
begin
if AFilename <> '' then
Result := PathExtractPath(AFilename)
else begin
{ If the script was not saved, default to My Documents }
Result := GetShellFolderPath(CSIDL_PERSONAL);
if Result = '' then
raise Exception.Create('GetShellFolderPath failed');
end;
end;
function ReadScriptLines(const ALines: TStringList; const ReadFromFile: Boolean;
const ReadFromFileFilename: String; const NotReadFromFileMemo: TScintEdit): Integer;
function ContainsNullChar(const S: String): Boolean;
var
I: Integer;
begin
Result := False;
for I := 1 to Length(S) do
if S[I] = #0 then begin
Result := True;
Break;
end;
end;
var
F: TTextFileReader;
I: Integer;
begin
if ReadFromFile then begin
F := TTextFileReader.Create(ReadFromFileFilename, fdOpenExisting, faRead, fsRead);
try
while not F.Eof do
ALines.Add(F.ReadLine);
finally
F.Free;
end;
end
else begin
ALines.Capacity := NotReadFromFileMemo.Lines.Count;
ALines.Assign(NotReadFromFileMemo.Lines);
end;
{ Check for null characters }
for I := 0 to ALines.Count-1 do begin
if ContainsNullChar(ALines[I]) then begin
Result := I;
Exit;
end;
end;
Result := -1;
end;
function CreateBitmapInfo(const Width, Height, BitCount: Integer): TBitmapInfo;
begin
ZeroMemory(@Result, SizeOf(Result));
Result.bmiHeader.biSize := SizeOf(Result.bmiHeader);
Result.bmiHeader.biWidth := Width;
Result.bmiHeader.biHeight := Height;
Result.bmiHeader.biPlanes := 1;
Result.bmiHeader.biBitCount := BitCount;
Result.bmiHeader.biCompression := BI_RGB;
end;
function GetWordOccurrenceFindOptions: TScintFindOptions;
begin
Result := [sfoMatchCase, sfoWholeWord];
end;
function GetSelTextOccurrenceFindOptions: TScintFindOptions;
begin
Result := [];
end;
var
PreferredMemoFont: String;
function GetPreferredMemoFont: String;
begin
Result := PreferredMemoFont;
end;
initialization
var OSVersionInfo: TOSVersionInfo;
OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo);
GetVersionEx(OSVersionInfo);
WindowsVersion := (Byte(OSVersionInfo.dwMajorVersion) shl 24) or (Byte(OSVersionInfo.dwMinorVersion) shl 16) or Word(OSVersionInfo.dwBuildNumber);
PreferredMemoFont := 'Consolas';
if not FontExists(PreferredMemoFont) then
PreferredMemoFont := 'Courier New';
end.