source: cprs/trunk/VA/VAUtils.pas@ 1071

Last change on this file since 1071 was 829, checked in by Kevin Toppenberg, 14 years ago

Upgrade to version 27

File size: 42.5 KB
Line 
1unit VAUtils;
2
3{TODO -oJeremy Merrill -cMessageHandlers : Change component list to use hex address for uComponentList
4search instead of IndexOfObject, so that it used a binary search
5on sorted text.}
6
7interface
8
9uses
10 SysUtils, Windows, Messages, Classes, Graphics, StrUtils, Controls, VAClasses, Forms,
11 SHFolder, ShlObj, PSAPI, ShellAPI, ComObj;
12
13type
14 TShow508MessageIcon = (smiNone, smiInfo, smiWarning, smiError, smiQuestion);
15 TShow508MessageButton = (smbOK, smbOKCancel, smbAbortRetryCancel, smbYesNoCancel,
16 smbYesNo, smbRetryCancel);
17 TShow508MessageResult = (smrOK, srmCancel, smrAbort, smrRetry, smrIgnore, smrYes, smrNo);
18
19function ShowMsg(const Msg, Caption: string; Icon: TShow508MessageIcon = smiNone;
20 Buttons: TShow508MessageButton = smbOK): TShow508MessageResult; overload;
21
22function ShowMsg(const Msg: string; Icon: TShow508MessageIcon = smiNone;
23 Buttons: TShow508MessageButton = smbOK): TShow508MessageResult; overload;
24
25const
26 SHARE_DIR = '\VISTA\Common Files\';
27
28{ returns the Nth piece (PieceNum) of a string delimited by Delim }
29function Piece(const S: string; Delim: char; PieceNum: Integer): string;
30{ returns several contiguous pieces }
31function Pieces(const S: string; Delim: char; FirstNum, LastNum: Integer): string;
32
33// Same as FreeAndNil, but for TString objects only
34// Frees any objects in the TStrings Objects list as well the TStrings object
35procedure FreeAndNilTStringsAndObjects(var Strings);
36
37// Returns true if a screen reader programm is running
38function ScreenReaderActive: boolean;
39
40// Special Coding for Screen Readers only enabled if screen reader was
41// running when the application first started up
42function ScreenReaderSupportEnabled: boolean;
43
44// Returns C:\...\subPath\File format based on maxSize and Canvas font setting
45function GetFileWithShortenedPath(FileName: String; MaxSize: integer; Canvas: TCanvas): string;
46
47const
48 HexChars: array[0..255] of string =
49 ('00','01','02','03','04','05','06','07','08','09','0A','0B','0C','0D','0E','0F',
50 '10','11','12','13','14','15','16','17','18','19','1A','1B','1C','1D','1E','1F',
51 '20','21','22','23','24','25','26','27','28','29','2A','2B','2C','2D','2E','2F',
52 '30','31','32','33','34','35','36','37','38','39','3A','3B','3C','3D','3E','3F',
53 '40','41','42','43','44','45','46','47','48','49','4A','4B','4C','4D','4E','4F',
54 '50','51','52','53','54','55','56','57','58','59','5A','5B','5C','5D','5E','5F',
55 '60','61','62','63','64','65','66','67','68','69','6A','6B','6C','6D','6E','6F',
56 '70','71','72','73','74','75','76','77','78','79','7A','7B','7C','7D','7E','7F',
57 '80','81','82','83','84','85','86','87','88','89','8A','8B','8C','8D','8E','8F',
58 '90','91','92','93','94','95','96','97','98','99','9A','9B','9C','9D','9E','9F',
59 'A0','A1','A2','A3','A4','A5','A6','A7','A8','A9','AA','AB','AC','AD','AE','AF',
60 'B0','B1','B2','B3','B4','B5','B6','B7','B8','B9','BA','BB','BC','BD','BE','BF',
61 'C0','C1','C2','C3','C4','C5','C6','C7','C8','C9','CA','CB','CC','CD','CE','CF',
62 'D0','D1','D2','D3','D4','D5','D6','D7','D8','D9','DA','DB','DC','DD','DE','DF',
63 'E0','E1','E2','E3','E4','E5','E6','E7','E8','E9','EA','EB','EC','ED','EE','EF',
64 'F0','F1','F2','F3','F4','F5','F6','F7','F8','F9','FA','FB','FC','FD','FE','FF');
65
66 DigitTable = '0123456789ABCDEF';
67
68 BinChars: array[0..15] of string =
69 ('0000', // 0
70 '0001', // 1
71 '0010', // 2
72 '0011', // 3
73 '0100', // 4
74 '0101', // 5
75 '0110', // 6
76 '0111', // 7
77 '1000', // 8
78 '1001', // 9
79 '1010', // 10
80 '1011', // 11
81 '1100', // 12
82 '1101', // 13
83 '1110', // 14
84 '1111');// 15
85
86type
87 TFastIntHexRec = record
88 case integer of
89 1: (lw: longword);
90 2: (b1, b2, b3, b4: byte);
91 end;
92
93 TFastWordHexRec = record
94 case integer of
95 1: (w: word);
96 2: (b1, b2: byte);
97 end;
98
99// returns an 8 digit hex number
100function FastIntToHex(Value: LongWord): String;
101
102// returns an 4 digit hex number
103function FastWordToHex(Value: Word): String;
104
105// takes only a 2 digit value - 1 byte - from above table
106function FastHexToByte(HexString: string): byte;
107
108// takes only an 8 digit value - 4 bytes
109function FastHexToInt(HexString: string): LongWord;
110
111// converts am upper case hex string of any length to binary
112function FastHexToBinary(HexString: string): string;
113
114{ returns a cyclic redundancy check for a string }
115function CRCForString(AString: string): DWORD;
116
117// If the string parameter does not end with a back slash, one is appended to the end
118// typically used for file path processing
119function AppendBackSlash(var txt: string): string;
120
121// returns special folder path on the current machine - such as Program Files etc
122// the parameter is a CSIDL windows constant
123function GetSpecialFolderPath(SpecialFolderCSIDL: integer): String;
124
125// returns Program Files path on current machine
126function GetProgramFilesPath: String;
127
128// returns Program Files path on the drive where the currently running application
129// resides, if it is a different drive than the one that contains the current
130// machine's Program Files directory. This is typically used for networked drives.
131function GetAlternateProgramFilesPath: String;
132
133// Get the Window title (Caption) of a window, given only it's handle
134function GetWindowTitle(Handle: HWND): String;
135
136// Get the Window class name string, given only it's window handle
137function GetWindowClassName(Handle: HWND): String;
138
139// Add or Remove a message handler to manage custom messages for an existing TWinControl
140type
141// TVAWinProcMessageEvent is used for raw windows messages not intercepted by the controls
142(*
143// doesn't work when the component's parent is changed, or anything else causes the
144 handle to be recreated.
145 TVAWinProcMessageEvent = function(hWnd: HWND; Msg: UINT;
146 wParam: WPARAM; lParam: LPARAM; var Handled: boolean): LRESULT of object;
147*)
148
149// TVAMessageEvent is used for windows messages that are intercepted by controls and are
150// converted to TMessage records - messages not intercepted in this manner should be
151// caught by TVAWinProcMessageEvent. Note that this is a different event structure
152// than the TMessageEvent used by TApplication, this uses TMessage rather than TMsg.
153 TVAMessageEvent = procedure (var Msg: TMessage; var Handled: Boolean) of object;
154
155//procedure AddMessageHandler(Control: TWinControl; MessageHandler: TVAWinProcMessageEvent); overload;
156procedure AddMessageHandler(Control: TWinControl; MessageHandler: TVAMessageEvent); overload;
157
158//procedure RemoveMessageHandler(Control: TWinControl; MessageHandler: TVAWinProcMessageEvent); overload;
159procedure RemoveMessageHandler(Control: TWinControl; MessageHandler: TVAMessageEvent); overload;
160
161// removes all message handlers, both TVAWinProcMessageEvent and TVAMessageEvent types
162procedure RemoveAllMessageHandlers(Control: TWinControl);
163
164function MessageHandlerCount(Control: TWinControl): integer;
165
166function GetInstanceCount(ApplicationNameAndPath: string): integer; overload;
167function GetInstanceCount: integer; overload;
168
169function AnotherInstanceRunning: boolean;
170
171procedure VersionStringSplit(const VerStr: string; var Val1: integer); overload;
172procedure VersionStringSplit(const VerStr: string; var Val1, Val2: integer); overload;
173procedure VersionStringSplit(const VerStr: string; var Val1, Val2, Val3: integer); overload;
174procedure VersionStringSplit(const VerStr: string; var Val1, Val2, Val3, Val4: integer); overload;
175
176function ExecuteAndWait(FileName: string; Parameters: String = ''): integer;
177
178// when called inside a DLL, returns the fully qualified name of the DLL file
179// must pass an address or a class or procedure that's been defined inside the DLL
180function GetDLLFileName(Address: Pointer): string;
181
182const
183 { values that can be passed to FileVersionValue }
184 FILE_VER_COMPANYNAME = 'CompanyName';
185 FILE_VER_FILEDESCRIPTION = 'FileDescription';
186 FILE_VER_FILEVERSION = 'FileVersion';
187 FILE_VER_INTERNALNAME = 'InternalName';
188 FILE_VER_LEGALCOPYRIGHT = 'LegalCopyright';
189 FILE_VER_ORIGINALFILENAME = 'OriginalFilename';
190 FILE_VER_PRODUCTNAME = 'ProductName';
191 FILE_VER_PRODUCTVERSION = 'ProductVersion';
192 FILE_VER_COMMENTS = 'Comments';
193
194function FileVersionValue(const AFileName, AValueName: string): string;
195
196// compares up to 4 pieces of a numeric version, returns true if CheckVersion is >= OriginalVersion
197// allows for . and , delimited version numbers
198function VersionOK(OriginalVersion, CheckVersion: string): boolean;
199
200implementation
201
202function Piece(const S: string; Delim: char; PieceNum: Integer): string;
203{ returns the Nth piece (PieceNum) of a string delimited by Delim }
204var
205 i: Integer;
206 Strt, Next: PChar;
207begin
208 i := 1;
209 Strt := PChar(S);
210 Next := StrScan(Strt, Delim);
211 while (i < PieceNum) and (Next <> nil) do
212 begin
213 Inc(i);
214 Strt := Next + 1;
215 Next := StrScan(Strt, Delim);
216 end;
217 if Next = nil then Next := StrEnd(Strt);
218 if i < PieceNum then Result := '' else SetString(Result, Strt, Next - Strt);
219end;
220
221function Pieces(const S: string; Delim: char; FirstNum, LastNum: Integer): string;
222{ returns several contiguous pieces }
223var
224 PieceNum: Integer;
225begin
226 Result := '';
227 for PieceNum := FirstNum to LastNum do Result := Result + Piece(S, Delim, PieceNum) + Delim;
228 if Length(Result) > 0 then Delete(Result, Length(Result), 1);
229end;
230
231//type
232// TShow508MessageIcon = (smiNone, smiInfo, smiWarning, smiError, smiQuestion);
233// TShow508MessageButton = (smbOK, smbOKCancel, smbAbortRetryCancel, smbYesNoCancel,
234// smbYesNo, smbRetryCancel);
235// TShow508MessageResult = (smrOK, srmCancel, smrAbort, smrRetry, smrIgnore, smrYes, smrNo);
236
237function ShowMsg(const Msg, Caption: string; Icon: TShow508MessageIcon = smiNone;
238 Buttons: TShow508MessageButton = smbOK): TShow508MessageResult; overload;
239var
240 Flags, Answer: Longint;
241 Title: string;
242begin
243 Flags := MB_TOPMOST;
244 case Icon of
245 smiInfo: Flags := Flags OR MB_ICONINFORMATION;
246 smiWarning: Flags := Flags OR MB_ICONWARNING;
247 smiError: Flags := Flags OR MB_ICONERROR;
248 smiQuestion: Flags := Flags OR MB_ICONQUESTION;
249 end;
250 case Buttons of
251 smbOK: Flags := Flags OR MB_OK;
252 smbOKCancel: Flags := Flags OR MB_OKCANCEL;
253 smbAbortRetryCancel: Flags := Flags OR MB_ABORTRETRYIGNORE;
254 smbYesNoCancel: Flags := Flags OR MB_YESNOCANCEL;
255 smbYesNo: Flags := Flags OR MB_YESNO;
256 smbRetryCancel: Flags := Flags OR MB_RETRYCANCEL;
257 end;
258 Title := Caption;
259 if Title = '' then
260 Title := Application.Title;
261 Answer := Application.MessageBox(PChar(Msg), PChar(Title), Flags);
262 case Answer of
263 IDCANCEL: Result := srmCancel;
264 IDABORT: Result := smrAbort;
265 IDRETRY: Result := smrRetry;
266 IDIGNORE: Result := smrIgnore;
267 IDYES: Result := smrYes;
268 IDNO: Result := smrNo;
269 else Result := smrOK; // IDOK
270 end;
271end;
272
273function ShowMsg(const Msg: string; Icon: TShow508MessageIcon = smiNone;
274 Buttons: TShow508MessageButton = smbOK): TShow508MessageResult;
275var
276 Caption: string;
277begin
278 Caption := '';
279 case Icon of
280 smiWarning: Caption := ' Warning';
281 smiError: Caption := ' Error';
282 smiQuestion: Caption := ' Inquiry';
283 end;
284 Caption := Application.Title + Caption;
285 Result := ShowMsg(Msg, Caption, Icon, Buttons);
286end;
287
288procedure FreeAndNilTStringsAndObjects(var Strings);
289var
290 i: integer;
291 list: TStrings;
292begin
293 list := TStrings(Strings);
294 for I := 0 to List.Count - 1 do
295 if assigned(list.Objects[i]) then
296 list.Objects[i].Free;
297 FreeAndNil(list);
298end;
299
300
301function ScreenReaderActive: boolean;
302var
303 ListStateOn : longbool;
304 Success: longbool;
305begin
306 //Determine if a screen reader is currently being used.
307 Success := SystemParametersInfo(SPI_GETSCREENREADER, 0, @ListStateOn,0);
308 if Success and ListStateOn then
309 Result := TRUE
310 else
311 Result := FALSE;
312end;
313
314var
315 CheckScreenReaderSupport: boolean = TRUE;
316 uScreenReaderSupportEnabled: boolean = FALSE;
317
318function ScreenReaderSupportEnabled: boolean;
319begin
320 if CheckScreenReaderSupport then
321 begin
322 uScreenReaderSupportEnabled := ScreenReaderActive;
323 CheckScreenReaderSupport := FALSE;
324 end;
325 Result := uScreenReaderSupportEnabled;
326end;
327
328const
329 DOTS = '...';
330 DOTS_LEN = Length(DOTS) + 2;
331
332// Returns C:\...\subPath\File format based on maxSize and Canvas font setting
333function GetFileWithShortenedPath(FileName: String; MaxSize: integer; Canvas: TCanvas): string;
334var
335 len, count, p, first, last: integer;
336
337begin
338 Result := FileName;
339 count := 0;
340 p := 0;
341 first := 0;
342 last := 0;
343
344 repeat
345 p := PosEx('\', Result, p+1);
346 if p > 0 then inc(count);
347 if first = 0 then
348 begin
349 first := p;
350 last := p+1;
351 end;
352 until p = 0;
353
354 repeat
355 len := Canvas.TextWidth(Result);
356 if (len > MaxSize) and (count > 0) then
357 begin
358 if count > 1 then
359 begin
360 p := last;
361 while(Result[p] <> '\') do inc(p);
362 Result := copy(Result,1,first) + DOTS + copy(Result,p,MaxInt);
363 last := first + DOTS_LEN;
364 end
365 else
366 Result := copy(Result, last, MaxInt);
367 dec(count);
368 end;
369 until (len <= MaxSize) or (count < 1);
370end;
371
372// returns an 8 digit hex number
373function FastIntToHex(Value: LongWord): String;
374var
375 v: TFastIntHexRec;
376begin
377 v.lw:= Value;
378 Result := HexChars[v.b4] + HexChars[v.b3] + HexChars[v.b2] + HexChars[v.b1];
379end;
380
381// returns an 4 digit hex number
382function FastWordToHex(Value: Word): String;
383var
384 v: TFastWordHexRec;
385begin
386 v.w:= Value;
387 Result := HexChars[v.b2] + HexChars[v.b1];
388end;
389
390const
391 b1Mult = 1;
392 b2Mult = b1Mult * 16;
393 b3Mult = b2Mult * 16;
394 b4Mult = b3Mult * 16;
395 b5Mult = b4Mult * 16;
396 b6Mult = b5Mult * 16;
397 b7Mult = b6Mult * 16;
398 b8Mult = b7Mult * 16;
399
400// takes only a 2 digit value - 1 byte - from above table
401function FastHexToByte(HexString: string): byte;
402begin
403 Result := ((pos(HexString[2], DigitTable) - 1) * b1Mult) +
404 ((pos(HexString[1], DigitTable) - 1) * b2Mult);
405end;
406
407// takes only an 8 digit value - 4 bytes
408function FastHexToInt(HexString: string): LongWord;
409begin
410 Result := ((pos(HexString[8], DigitTable) - 1) * b1Mult) +
411 ((pos(HexString[7], DigitTable) - 1) * b2Mult) +
412 ((pos(HexString[6], DigitTable) - 1) * b3Mult) +
413 ((pos(HexString[5], DigitTable) - 1) * b4Mult) +
414 ((pos(HexString[4], DigitTable) - 1) * b5Mult) +
415 ((pos(HexString[3], DigitTable) - 1) * b6Mult) +
416 ((pos(HexString[2], DigitTable) - 1) * b7Mult) +
417 ((pos(HexString[1], DigitTable) - 1) * b8Mult);
418end;
419
420// converts a hex string to binary
421function FastHexToBinary(HexString: string): string;
422var
423 i, len, val: integer;
424 chr: string;
425begin
426 len := length(HexString);
427 Result := '';
428 for I := 1 to len do
429 begin
430 chr := HexString[i];
431 val := pos(chr, DigitTable);
432 if val > 0 then
433 Result := Result + BinChars[val-1]
434 end;
435end;
436
437const
438{ copied from ORFn - table for calculating CRC values }
439 CRC32_TABLE: array[0..255] of DWORD =
440 ($0, $77073096, $EE0E612C, $990951BA, $76DC419, $706AF48F, $E963A535, $9E6495A3,
441 $EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988, $9B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
442 $1DB71064, $6AB020F2, $F3B97148, $84BE41DE, $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
443 $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC, $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
444 $3B6E20C8, $4C69105E, $D56041E4, $A2677172, $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
445 $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940, $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
446 $26D930AC, $51DE003A, $C8D75180, $BFD06116, $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
447 $2802B89E, $5F058808, $C60CD9B2, $B10BE924, $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,
448 $76DC4190, $1DB7106, $98D220BC, $EFD5102A, $71B18589, $6B6B51F, $9FBFE4A5, $E8B8D433,
449 $7807C9A2, $F00F934, $9609A88E, $E10E9818, $7F6A0DBB, $86D3D2D, $91646C97, $E6635C01,
450 $6B6B51F4, $1C6C6162, $856530D8, $F262004E, $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
451 $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C, $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
452 $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2, $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
453 $4369E96A, $346ED9FC, $AD678846, $DA60B8D0, $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
454 $5005713C, $270241AA, $BE0B1010, $C90C2086, $5768B525, $206F85B3, $B966D409, $CE61E49F,
455 $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4, $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,
456 $EDB88320, $9ABFB3B6, $3B6E20C, $74B1D29A, $EAD54739, $9DD277AF, $4DB2615, $73DC1683,
457 $E3630B12, $94643B84, $D6D6A3E, $7A6A5AA8, $E40ECF0B, $9309FF9D, $A00AE27, $7D079EB1,
458 $F00F9344, $8708A3D2, $1E01F268, $6906C2FE, $F762575D, $806567CB, $196C3671, $6E6B06E7,
459 $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC, $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
460 $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252, $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
461 $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60, $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
462 $CB61B38C, $BC66831A, $256FD2A0, $5268E236, $CC0C7795, $BB0B4703, $220216B9, $5505262F,
463 $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04, $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,
464 $9B64C2B0, $EC63F226, $756AA39C, $26D930A, $9C0906A9, $EB0E363F, $72076785, $5005713,
465 $95BF4A82, $E2B87A14, $7BB12BAE, $CB61B38, $92D28E9B, $E5D5BE0D, $7CDCEFB7, $BDBDF21,
466 $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E, $81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
467 $88085AE6, $FF0F6A70, $66063BCA, $11010B5C, $8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
468 $A00AE278, $D70DD2EE, $4E048354, $3903B3C2, $A7672661, $D06016F7, $4969474D, $3E6E77DB,
469 $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0, $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
470 $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6, $BAD03605, $CDD70693, $54DE5729, $23D967BF,
471 $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94, $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);
472
473{ returns a cyclic redundancy check for a string }
474function CRCForString(AString: string): DWORD;
475var
476 i: Integer;
477begin
478 Result:=$FFFFFFFF;
479 for i := 1 to Length(AString) do
480 Result:=((Result shr 8) and $00FFFFFF) xor
481 CRC32_TABLE[(Result xor Ord(AString[i])) and $000000FF];
482end;
483
484function AppendBackSlash(var txt: string): string;
485begin
486 if RightStr(txt,1) <> '\' then
487 txt := txt + '\';
488 Result := txt;
489end;
490
491// returns special folder path on the current machine - such as Program Files etc
492// the parameter is a CSIDL windows constant
493function GetSpecialFolderPath(SpecialFolderCSIDL: integer): String;
494var
495 Path: array[0..Max_Path] of Char;
496begin
497 Path := '';
498 SHGetSpecialFolderPath(0, Path, SpecialFolderCSIDL, false);
499 Result := Path;
500 AppendBackSlash(Result);
501end;
502
503// returns Program Files path on current machine
504function GetProgramFilesPath: String;
505begin
506 Result := GetSpecialFolderPath(CSIDL_PROGRAM_FILES);
507end;
508
509// returns Program Files path on the drive where the currently running application
510// resides, if it is a different drive than the one that contains the current
511// machine's Program Files directory. This is typically used for networked drives.
512// Note that tnis only works if the mapping to the network is at the root drive
513function GetAlternateProgramFilesPath: String;
514var
515 Dir, Dir2: string;
516
517begin
518 Dir := GetProgramFilesPath;
519 Dir2 := ExtractFileDrive(Application.ExeName);
520 AppendBackSlash(Dir2);
521 Dir2 := Dir2 + 'Program Files\';
522 If (UpperCase(Dir) = UpperCase(Dir2)) then
523 Result := ''
524 else
525 Result := Dir2;
526end;
527
528// Get the Window title (Caption) of a window, given only it's handle
529function GetWindowTitle(Handle: HWND): String;
530begin
531 SetLength(Result, 240);
532 SetLength(Result, GetWindowText(Handle, PChar(Result), Length(Result)));
533end;
534
535function GetWindowClassName(Handle: HWND): String;
536begin
537 SetLength(Result, 240);
538 SetLength(Result, GetClassName(Handle, PChar(Result), Length(Result)));
539end;
540
541type
542(*
543 TVACustomWinProcInterceptor = class
544 private
545 FOldWinProc: Pointer;
546 FHexHandle: string;
547 FComponent: TWinControl;
548 procedure Initialize;
549 protected
550 constructor Create(Component: TWinControl); virtual;
551 function NewWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; virtual;
552// property OldWindowProc: Pointer read FOldWinProc;
553// property Component: TWinControl read FComponent;
554 public
555 destructor Destroy; override;
556 end;
557*)
558(*
559 TVAWinProcMessageHandler = class(TVACustomWinProcInterceptor)
560 private
561 FMessageHandlerList: TVAMethodList;
562 function DoMessageHandlers(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM; var MessageHandled: boolean): LRESULT;
563 protected
564 constructor Create(Component: TWinControl); override;
565 function NewWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; override;
566 public
567 destructor Destroy; override;
568 function HandlerCount: integer;
569 procedure AddMessageHandler(event: TVAWinProcMessageEvent);
570 procedure RemoveMessageHandler(event: TVAWinProcMessageEvent);
571 end;
572*)
573
574 TVACustomMessageEventInterceptor = class
575 private
576 FOldWndMethod: TWndMethod;
577 FComponent: TWinControl;
578 protected
579 constructor Create(Component: TWinControl); virtual;
580 procedure NewMessageHandler(var Message: TMessage); virtual;
581// property OldWndMethod: TWndMethod read FOldWndMethod;
582// property Component: TWinControl read FComponent;
583 public
584 destructor Destroy; override;
585 end;
586
587 TVAMessageEventHandler = class(TVACustomMessageEventInterceptor)
588 private
589 FMessageHandlerList: TVAMethodList;
590 procedure DoMessageHandlers(var Message: TMessage; var MessageHandled: boolean);
591 protected
592 constructor Create(Component: TWinControl); override;
593 procedure NewMessageHandler(var Message: TMessage); override;
594 public
595 destructor Destroy; override;
596 function HandlerCount: integer;
597 procedure AddMessageHandler(event: TVAMessageEvent);
598 procedure RemoveMessageHandler(event: TVAMessageEvent);
599 end;
600
601(*
602 TVAWinProcAccessClass = class(TWinControl)
603 public
604 property DefWndProc;
605 end;
606*)
607
608 TVAWinProcMonitor = class(TComponent)
609 protected
610 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
611 public
612 procedure RemoveFromList(AComponent: TComponent);
613 end;
614
615
616var
617// uWinProcMessageHandlers: TStringList = nil;
618 uEventMessageHandlers: TStringList = nil;
619 uHandlePointers: TStringlist = nil;
620 uWinProcMonitor: TVAWinProcMonitor = nil;
621 uMessageHandlerSystemRunning: boolean = FALSE;
622
623procedure InitializeMessageHandlerSystem;
624begin
625 if not uMessageHandlerSystemRunning then
626 begin
627// uWinProcMessageHandlers := TStringList.Create;
628// uWinProcMessageHandlers.Sorted := TRUE;
629// uWinProcMessageHandlers.Duplicates := dupAccept;
630 uEventMessageHandlers := TStringList.Create;
631 uEventMessageHandlers.Sorted := TRUE;
632 uEventMessageHandlers.Duplicates := dupAccept;
633 uHandlePointers := TStringList.Create;
634 uHandlePointers.Sorted := TRUE; // allows for faster binary searching
635 uHandlePointers.Duplicates := dupAccept;
636 uWinProcMonitor := TVAWinProcMonitor.Create(nil);
637 uMessageHandlerSystemRunning := TRUE;
638 end;
639end;
640
641procedure CleanupMessageHandlerSystem;
642
643 procedure Clear(var list: TStringList; FreeObjects: boolean = false);
644 var
645 i: integer;
646 begin
647 if assigned(list) then
648 begin
649 if FreeObjects then
650 begin
651 for I := 0 to list.Count - 1 do
652 list.Objects[i].Free;
653 end;
654 FreeAndNil(list);
655 end;
656 end;
657
658begin
659// Clear(uWinProcMessageHandlers, TRUE);
660 Clear(uEventMessageHandlers, TRUE);
661 Clear(uHandlePointers);
662 if assigned(uWinProcMonitor) then
663 FreeAndNil(uWinProcMonitor);
664 uMessageHandlerSystemRunning := FALSE;
665end;
666
667(*
668procedure AddMessageHandler(Control: TWinControl; MessageHandler: TVAWinProcMessageEvent);
669var
670 HexID: string;
671 idx: integer;
672 Handler: TVAWinProcMessageHandler;
673
674begin
675 InitializeMessageHandlerSystem;
676 HexID := FastIntToHex(LongWord(Control));
677 idx := uWinProcMessageHandlers.IndexOf(HexID);
678 if idx < 0 then
679 begin
680 Handler := TVAWinProcMessageHandler.Create(Control);
681 uWinProcMessageHandlers.AddObject(HexID, Handler);
682 end
683 else
684 Handler := TVAWinProcMessageHandler(uWinProcMessageHandlers.Objects[idx]);
685 Handler.AddMessageHandler(MessageHandler);
686end;
687*)
688
689procedure AddMessageHandler(Control: TWinControl; MessageHandler: TVAMessageEvent);
690var
691 HexID: string;
692 idx: integer;
693 Handler: TVAMessageEventHandler;
694
695begin
696 InitializeMessageHandlerSystem;
697 HexID := FastIntToHex(LongWord(Control));
698 idx := uEventMessageHandlers.IndexOf(HexID);
699 if idx < 0 then
700 begin
701 Handler := TVAMessageEventHandler.Create(Control);
702 uEventMessageHandlers.AddObject(HexID, Handler);
703 end
704 else
705 Handler := TVAMessageEventHandler(uEventMessageHandlers.Objects[idx]);
706 Handler.AddMessageHandler(MessageHandler);
707end;
708
709(*
710procedure RemoveMessageHandler(Control: TWinControl;
711 MessageHandler: TVAWinProcMessageEvent);
712var
713 HexID: string;
714 idx: integer;
715 Handler: TVAWinProcMessageHandler;
716
717begin
718 if not uMessageHandlerSystemRunning then exit;
719 HexID := FastIntToHex(LongWord(Control));
720 idx := uWinProcMessageHandlers.IndexOf(HexID);
721 if idx >= 0 then
722 begin
723 Handler := TVAWinProcMessageHandler(uWinProcMessageHandlers.Objects[idx]);
724 Handler.RemoveMessageHandler(MessageHandler);
725 if Handler.HandlerCount = 0 then
726 begin
727 Handler.Free;
728 uWinProcMessageHandlers.Delete(idx);
729 end;
730 end;
731end;
732*)
733
734procedure RemoveMessageHandler(Control: TWinControl; MessageHandler: TVAMessageEvent);
735var
736 HexID: string;
737 idx: integer;
738 Handler: TVAMessageEventHandler;
739
740begin
741 if not uMessageHandlerSystemRunning then exit;
742 HexID := FastIntToHex(LongWord(Control));
743 idx := uEventMessageHandlers.IndexOf(HexID);
744 if idx >= 0 then
745 begin
746 Handler := TVAMessageEventHandler(uEventMessageHandlers.Objects[idx]);
747 Handler.RemoveMessageHandler(MessageHandler);
748 if Handler.HandlerCount = 0 then
749 begin
750 Handler.Free;
751 uEventMessageHandlers.Delete(idx);
752 end;
753 end;
754end;
755
756procedure RemoveAllMessageHandlers(Control: TWinControl);
757var
758 HexID: string;
759 idx: integer;
760// Handler: TVAWinProcMessageHandler;
761 EventHandler: TVAMessageEventHandler;
762
763begin
764 if not uMessageHandlerSystemRunning then exit;
765 HexID := FastIntToHex(LongWord(Control));
766
767 (*
768 idx := uWinProcMessageHandlers.IndexOf(HexID);
769
770 if idx >= 0 then
771 begin
772 Handler := TVAWinProcMessageHandler(uWinProcMessageHandlers.Objects[idx]);
773 Handler.Free;
774 uWinProcMessageHandlers.Delete(idx);
775 end;
776 *)
777
778 idx := uEventMessageHandlers.IndexOf(HexID);
779 if idx >= 0 then
780 begin
781 EventHandler := TVAMessageEventHandler(uEventMessageHandlers.Objects[idx]);
782 EventHandler.Free;
783 uEventMessageHandlers.Delete(idx);
784 end;
785
786 Control.RemoveFreeNotification(uWinProcMonitor);
787end;
788
789function MessageHandlerCount(Control: TWinControl): integer;
790var
791 HexID: string;
792 idx: integer;
793// Handler: TVAWinProcMessageHandler;
794 EventHandler: TVAMessageEventHandler;
795
796begin
797 Result := 0;
798 if not uMessageHandlerSystemRunning then exit;
799
800 HexID := FastIntToHex(LongWord(Control));
801
802(* idx := uWinProcMessageHandlers.IndexOf(HexID);
803
804 if idx >= 0 then
805 begin
806 Handler := TVAWinProcMessageHandler(uWinProcMessageHandlers.Objects[idx]);
807 result := Handler.HandlerCount;
808 end;
809*)
810
811 idx := uEventMessageHandlers.IndexOf(HexID);
812 if idx >= 0 then
813 begin
814 EventHandler := TVAMessageEventHandler(uEventMessageHandlers.Objects[idx]);
815 inc(Result, EventHandler.HandlerCount);
816 end;
817end;
818
819 { TVACustomWinProc }
820
821(*
822constructor TVACustomWinProcInterceptor.Create(Component: TWinControl);
823begin
824 if not Assigned(Component) then
825 raise EInvalidPointer.Create('Component parameter unassigned');
826 FComponent := Component;
827 Initialize;
828end;
829
830destructor TVACustomWinProcInterceptor.Destroy;
831var
832 idx: integer;
833begin
834 if Assigned(FComponent) then
835 begin
836 try
837 TVAWinProcAccessClass(FComponent).DefWndProc := FOldWinProc;
838 except // just in case FComponent has been destroyed
839 end;
840 end;
841 idx := uHandlePointers.IndexOf(FHexHandle);
842 if idx >= 0 then
843 uHandlePointers.Delete(idx);
844 inherited;
845end;
846
847function TVACustomWinProcInterceptor.NewWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
848begin
849{
850 if (Msg = SOME_MESSAGE) then
851 begin
852 ...
853 Result := S_OK;
854 end
855 else
856}
857 Result := CallWindowProc(FOldWinProc, hWnd, Msg, WParam, LParam);
858end;
859
860
861function BaseWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
862var
863 idx: integer;
864
865begin
866 idx := uHandlePointers.IndexOf(FastIntToHex(hWnd)); // does binary search on sorted string list
867 if idx >= 0 then
868 Result := TVACustomWinProcInterceptor(uHandlePointers.Objects[idx]).NewWindowProc(hWnd, Msg, wParam, lParam)
869 else
870 Result := 0; // should never happen
871end;
872
873procedure TVACustomWinProcInterceptor.Initialize;
874var
875 idx: integer;
876begin
877 InitializeMessageHandlerSystem;
878 FComponent.HandleNeeded;
879 FHexHandle := FastIntToHex(FComponent.Handle);
880 idx := uHandlePointers.IndexOf(FHexHandle);
881 if idx < 0 then
882 uHandlePointers.AddObject(FHexHandle, Self)
883 else
884 uHandlePointers.Objects[idx] := Self;
885 FComponent.FreeNotification(uWinProcMonitor);
886 FOldWinProc := TVAWinProcAccessClass(FComponent).DefWndProc;
887 TVAWinProcAccessClass(FComponent).DefWndProc := @BaseWindowProc;
888end;
889*)
890
891{ TVAWinProcMonitor }
892
893
894// assumes object is responsible for deleting instance of TVACustomWinProc
895procedure TVAWinProcMonitor.Notification(AComponent: TComponent;
896 Operation: TOperation);
897begin
898 inherited;
899 if (Operation = opRemove) and (AComponent is TWinControl) then
900 RemoveFromList(AComponent);
901end;
902
903procedure TVAWinProcMonitor.RemoveFromList(AComponent: TComponent);
904begin
905 if AComponent is TWinControl then
906 RemoveAllMessageHandlers(TWinControl(AComponent));
907end;
908
909
910{ TVACustomMessageEventInterceptor }
911
912constructor TVACustomMessageEventInterceptor.Create(Component: TWinControl);
913begin
914 if not Assigned(Component) then
915 raise EInvalidPointer.Create('Component parameter unassigned');
916 FComponent := Component;
917 FComponent.FreeNotification(uWinProcMonitor);
918 FOldWndMethod := FComponent.WindowProc;
919 FComponent.WindowProc := NewMessageHandler;
920end;
921
922destructor TVACustomMessageEventInterceptor.Destroy;
923begin
924 FComponent.WindowProc := FOldWndMethod;
925 inherited;
926end;
927
928procedure TVACustomMessageEventInterceptor.NewMessageHandler(
929 var Message: TMessage);
930begin
931 FOldWndMethod(Message);
932end;
933
934{ TVAWinProcNotifier }
935
936(*
937procedure TVAWinProcMessageHandler.AddMessageHandler(event: TVAWinProcMessageEvent);
938begin
939 FMessageHandlerList.Add(TMethod(event));
940end;
941
942constructor TVAWinProcMessageHandler.Create(Component: TWinControl);
943begin
944 FMessageHandlerList := TVAMethodList.Create;
945 inherited Create(Component);
946end;
947
948destructor TVAWinProcMessageHandler.Destroy;
949begin
950 inherited;
951 FMessageHandlerList.Free;
952end;
953
954function TVAWinProcMessageHandler.DoMessageHandlers(hWnd: HWND; Msg: UINT;
955 wParam: WPARAM; lParam: LPARAM; var MessageHandled: boolean): LRESULT;
956var
957 Method: TMethod;
958 i: integer;
959begin
960 MessageHandled := FALSE;
961 Result := 0;
962 for i := 0 to FMessageHandlerList.Count - 1 do
963 begin
964 Method := FMessageHandlerList[i];
965 Result := TVAWinProcMessageEvent(Method)(hWnd, Msg, wParam, lParam, MessageHandled);
966 if MessageHandled then
967 break;
968 end;
969end;
970
971function TVAWinProcMessageHandler.HandlerCount: integer;
972begin
973 Result := FMessageHandlerList.Count;
974end;
975
976function TVAWinProcMessageHandler.NewWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM;
977 lParam: LPARAM): LRESULT;
978var
979 MessageHandled: boolean;
980
981begin
982 Result := DoMessageHandlers(hWnd, Msg, wParam, lParam, MessageHandled);
983 if not MessageHandled then
984 Result := CallWindowProc(FOldWinProc, hWnd, Msg, WParam, LParam);
985end;
986
987procedure TVAWinProcMessageHandler.RemoveMessageHandler(event: TVAWinProcMessageEvent);
988begin
989 FMessageHandlerList.Remove(TMethod(event));
990end;
991*)
992
993{ TVAMessageEventHandler }
994
995procedure TVAMessageEventHandler.AddMessageHandler(event: TVAMessageEvent);
996begin
997 FMessageHandlerList.Add(TMethod(event));
998end;
999
1000constructor TVAMessageEventHandler.Create(Component: TWinControl);
1001begin
1002 FMessageHandlerList := TVAMethodList.Create;
1003 inherited Create(Component);
1004end;
1005
1006destructor TVAMessageEventHandler.Destroy;
1007begin
1008 inherited;
1009 FMessageHandlerList.Free;
1010end;
1011
1012procedure TVAMessageEventHandler.DoMessageHandlers(var Message: TMessage;
1013 var MessageHandled: boolean);
1014var
1015 Method: TMethod;
1016 i: integer;
1017
1018begin
1019 MessageHandled := FALSE;
1020 for i := 0 to FMessageHandlerList.Count - 1 do
1021 begin
1022 Method := FMessageHandlerList[i];
1023 TVAMessageEvent(Method)(Message, MessageHandled);
1024 if MessageHandled then
1025 break;
1026 end;
1027end;
1028
1029function TVAMessageEventHandler.HandlerCount: integer;
1030begin
1031 Result := FMessageHandlerList.Count;
1032end;
1033
1034procedure TVAMessageEventHandler.NewMessageHandler(var Message: TMessage);
1035var
1036 MessageHandled: boolean;
1037
1038begin
1039 DoMessageHandlers(Message, MessageHandled);
1040 if not MessageHandled then
1041 FOldWndMethod(Message);
1042end;
1043
1044procedure TVAMessageEventHandler.RemoveMessageHandler(event: TVAMessageEvent);
1045begin
1046 FMessageHandlerList.Remove(TMethod(event));
1047end;
1048
1049
1050
1051type
1052 TDataArray = record
1053 private
1054 FCapacity: integer;
1055 procedure SetCapacity(Value: integer);
1056 public
1057 Data: array of DWORD;
1058 Count: integer;
1059 procedure Clear;
1060 function Size: integer;
1061 property Capacity: integer read FCapacity write SetCapacity;
1062 end;
1063
1064{ TDataArray }
1065
1066procedure TDataArray.Clear;
1067begin
1068 SetCapacity(0);
1069 SetCapacity(128);
1070end;
1071
1072procedure TDataArray.SetCapacity(Value: integer);
1073begin
1074 if FCapacity <> Value then
1075 begin
1076 FCapacity := Value;
1077 SetLength(Data, Value);
1078 if Count >= Value then
1079 Count := Value - 1;
1080 end;
1081end;
1082
1083
1084function TDataArray.Size: integer;
1085begin
1086 Result := FCapacity * SizeOf(DWORD);
1087end;
1088
1089var
1090 PIDList: TDataArray;
1091 ModuleHandles: TDataArray;
1092
1093function GetInstanceCount(ApplicationNameAndPath: string): integer; overload;
1094var
1095 i, j: DWORD;
1096 name: string;
1097 process: THandle;
1098 Output: DWORD;
1099 current: string;
1100 ok: BOOL;
1101 done: boolean;
1102
1103 function ListTooSmall(var Data: TDataArray): boolean;
1104 var
1105 ReturnCount: integer;
1106 begin
1107 Data.Count := 0;
1108 ReturnCount := Output div SizeOf(DWORD);
1109 Result := (ReturnCount >= Data.Capacity);
1110 if Result then
1111 Data.Capacity := Data.Capacity * 2
1112 else
1113 Data.Count := ReturnCount;
1114 end;
1115
1116begin
1117 Result := 0;
1118 current := UpperCase(ApplicationNameAndPath);
1119 PIDList.Clear;
1120 repeat
1121 done := TRUE;
1122 ok := EnumProcesses(pointer(PIDList.Data), PIDList.Size, Output);
1123 if ok and ListTooSmall(PIDList) then
1124 done := FALSE;
1125 until done or (not ok);
1126 if ok then
1127 begin
1128 for I := 0 to PIDList.Count - 1 do
1129 begin
1130 Process := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, FALSE, PIDList.Data[i]);
1131 if Process <> 0 then
1132 begin
1133 try
1134 ModuleHandles.Clear;
1135 repeat
1136 done := TRUE;
1137 ok := EnumProcessModules(Process, Pointer(ModuleHandles.Data), ModuleHandles.Size, Output);
1138 if ok and ListTooSmall(ModuleHandles) then
1139 done := FALSE;
1140 until done or (not ok);
1141 if ok then
1142 begin
1143 for j := 0 to ModuleHandles.Count - 1 do
1144 begin
1145 SetLength(name, MAX_PATH*2);
1146 SetLength(name, GetModuleFileNameEx(Process, ModuleHandles.Data[j], PChar(name), MAX_PATH*2));
1147 name := UpperCase(name);
1148 if name = current then
1149 begin
1150 inc(Result);
1151 break;
1152 end;
1153 end;
1154 end;
1155 finally
1156 CloseHandle(Process);
1157 end;
1158 end;
1159 end;
1160 end;
1161 PIDList.SetCapacity(0);
1162 ModuleHandles.SetCapacity(0);
1163end;
1164
1165
1166function GetInstanceCount: integer;
1167begin
1168 Result := GetInstanceCount(ParamStr(0));
1169end;
1170
1171function AnotherInstanceRunning: boolean;
1172begin
1173 Result := (GetInstanceCount > 1);
1174end;
1175
1176procedure VersionStringSplit(const VerStr: string; var Val1: integer);
1177var
1178 dummy2, dummy3, dummy4: integer;
1179begin
1180 VersionStringSplit(VerStr, Val1, dummy2, dummy3, dummy4);
1181end;
1182
1183procedure VersionStringSplit(const VerStr: string; var Val1, Val2: integer);
1184var
1185 dummy3, dummy4: integer;
1186begin
1187 VersionStringSplit(VerStr, Val1, Val2, dummy3, dummy4);
1188end;
1189
1190procedure VersionStringSplit(const VerStr: string; var Val1, Val2, Val3: integer);
1191var
1192 dummy4: integer;
1193begin
1194 VersionStringSplit(VerStr, Val1, Val2, Val3, dummy4);
1195end;
1196
1197procedure VersionStringSplit(const VerStr: string; var Val1, Val2, Val3, Val4: integer);
1198var
1199 temp: string;
1200
1201 function GetNum: integer;
1202 var
1203 idx: integer;
1204
1205 begin
1206 idx := pos('.', temp);
1207 if idx < 1 then
1208 idx := Length(temp) + 1;
1209 Result := StrToIntDef(copy(temp, 1, idx-1), 0);
1210 delete(temp, 1, idx);
1211 end;
1212
1213begin
1214 temp := VerStr;
1215 Val1 := GetNum;
1216 Val2 := GetNum;
1217 Val3 := GetNum;
1218 Val4 := GetNum;
1219end;
1220
1221const
1222 FILE_VER_PREFIX = '\StringFileInfo\';
1223// FILE_VER_COMMENTS = '\StringFileInfo\040904E4\Comments';
1224
1225function FileVersionValue(const AFileName, AValueName: string): string;
1226type
1227 TValBuf = array[0..255] of Char;
1228 PValBuf = ^TValBuf;
1229
1230var
1231 VerSize, ValSize, AHandle: DWORD;
1232 VerBuf: Pointer;
1233 ValBuf: PValBuf;
1234 Output, Query: string;
1235 POutput: PChar;
1236begin
1237 Result := '';
1238 VerSize:=GetFileVersionInfoSize(PChar(AFileName), AHandle);
1239 if VerSize > 0 then
1240 begin
1241 GetMem(VerBuf, VerSize);
1242 try
1243 GetFileVersionInfo(PChar(AFileName), AHandle, VerSize, VerBuf);
1244 VerQueryValue(VerBuf, PChar('\VarFileInfo\Translation'), Pointer(ValBuf), ValSize);
1245 Query := FILE_VER_PREFIX + IntToHex(LoWord(PLongInt(ValBuf)^),4)+
1246 IntToHex(HiWord(PLongInt(ValBuf)^),4)+
1247 '\'+AValueName;
1248 VerQueryValue(VerBuf, PChar(Query), Pointer(ValBuf), ValSize);
1249 SetString(Output, ValBuf^, ValSize);
1250 POutput := PChar(Output);
1251 Result := POutput;
1252 finally
1253 FreeMem(VerBuf);
1254 end;
1255 end;
1256end;
1257
1258// compares up to 4 pieces of a numeric version, returns true if CheckVersion is >= OriginalVersion
1259// allows for . and , delimited version numbers
1260function VersionOK(OriginalVersion, CheckVersion: string): boolean;
1261var
1262 v1, v2, v3, v4, r1, r2, r3, r4: Integer;
1263
1264 function GetV(var Version: string): integer;
1265 var
1266 idx: integer;
1267 delim: string;
1268 begin
1269 if pos('.', Version) > 0 then
1270 delim := '.'
1271 else
1272 delim := ',';
1273 idx := pos(delim, version);
1274 if idx < 1 then
1275 idx := length(Version) + 1;
1276 Result := StrToIntDef(copy(version, 1, idx-1), 0);
1277 delete(version, 1, idx);
1278 end;
1279
1280 procedure parse(const v: string; var p1, p2, p3, p4: integer);
1281 var
1282 version: string;
1283 begin
1284 version := v;
1285 p1 := GetV(version);
1286 p2 := GetV(version);
1287 p3 := GetV(version);
1288 p4 := GetV(version);
1289 end;
1290
1291begin
1292 parse(OriginalVersion, r1, r2, r3, r4);
1293 parse(CheckVersion, v1, v2, v3, v4);
1294 Result := FALSE;
1295 if v1 > r1 then
1296 Result := TRUE
1297 else if v1 = r1 then
1298 begin
1299 if v2 > r2 then
1300 Result := TRUE
1301 else if v2 = r2 then
1302 begin
1303 if v3 > r3 then
1304 Result := TRUE
1305 else if v3 = r3 then
1306 begin
1307 if v4 >= r4 then
1308 Result := TRUE
1309 end;
1310 end;
1311 end;
1312end;
1313
1314function ExecuteAndWait(FileName: string; Parameters: String = ''): integer;
1315var
1316 exec, shell: OleVariant;
1317 line: string;
1318
1319begin
1320 if copy(FileName,1,1) <> '"' then
1321 line := '"' + FileName + '"'
1322 else
1323 line := FileName;
1324 if Parameters <> '' then
1325 line := line + ' ' + Parameters;
1326 shell := CreateOleObject('WScript.Shell');
1327 try
1328 exec := shell.Exec(line);
1329 try
1330 While exec.status = 0 do
1331 Sleep(100);
1332 Result := Exec.ExitCode;
1333 finally
1334 VarClear(exec);
1335 end;
1336 finally
1337 VarClear(shell);
1338 end;
1339end;
1340
1341{
1342function ExecuteAndWait(FileName: string; Parameters: String = ''): DWORD;
1343var
1344 SEI:TShellExecuteInfo;
1345begin
1346 FillChar(SEI,SizeOf(SEI),0);
1347 with SEI do begin
1348 cbSize:=SizeOf(SEI);
1349 lpVerb:='open';
1350 lpFile:=PAnsiChar(FileName);
1351 lpDirectory := PAnsiChar(ExtractFileDir(FileName));
1352 if Parameters <> '' then
1353 lpParameters := PAnsiChar(Parameters);
1354 nShow:=SW_SHOW;
1355 fMask:=SEE_MASK_NOCLOSEPROCESS;
1356 end;
1357 ShellExecuteEx(@SEI);
1358 WaitForSingleObject(SEI.hProcess, INFINITE);
1359 if not GetExitCodeProcess(SEI.hProcess, Result) then
1360 Result := 0;
1361 CloseHandle(SEI.hProcess);
1362end;
1363 }
1364
1365// when called inside a DLL, returns the fully qualified name of the DLL file
1366// must pass an address or a class or procedure that's been defined inside the DLL
1367function GetDLLFileName(Address: Pointer): string;
1368var
1369 ProcessHandle: THandle;
1370 Output: DWORD;
1371 i, max: integer;
1372 ModuleHandles: array[0..1023] of HMODULE;
1373 info: _MODULEINFO;
1374 pinfo: LPMODULEINFO;
1375 adr: Int64;
1376
1377begin
1378 Result := '';
1379 ProcessHandle := GetCurrentProcess;
1380 if EnumProcessModules(ProcessHandle, @ModuleHandles, sizeof(ModuleHandles), output) then
1381 begin
1382 adr := Int64(Address);
1383 max := (output div sizeof(HMODULE))-1;
1384 pinfo := @info;
1385 for i := 0 to max do
1386 begin
1387 if GetModuleInformation(ProcessHandle, ModuleHandles[i], pinfo, sizeof(_MODULEINFO)) then
1388 begin
1389 if (adr > Int64(info.lpBaseOfDll)) and (adr < (Int64(info.lpBaseOfDll) + info.SizeOfImage)) then
1390 begin
1391 SetLength(Result, MAX_PATH);
1392 SetLength(Result, GetModuleFileName(ModuleHandles[i], PChar(Result), Length(Result)));
1393 break;
1394 end;
1395 end;
1396 end;
1397 end;
1398end;
1399
1400initialization
1401 ScreenReaderSupportEnabled;
1402
1403finalization
1404 CleanupMessageHandlerSystem;
1405
1406end.
1407
Note: See TracBrowser for help on using the repository browser.