source: cprs/branches/HealthSevak-CPRS/VA/VAUtils.pas@ 1698

Last change on this file since 1698 was 1695, checked in by healthsevak, 9 years ago

updated these files for version 28

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