1416 lines
43 KiB
Plaintext
1416 lines
43 KiB
Plaintext
unit VAUtils;
|
|
|
|
{TODO -oJeremy Merrill -cMessageHandlers : Change component list to use hex address for uComponentList
|
|
search instead of IndexOfObject, so that it used a binary search
|
|
on sorted text.}
|
|
|
|
interface
|
|
|
|
uses
|
|
SysUtils, Windows, Messages, Classes, Graphics, StrUtils, Controls, VAClasses, Forms,
|
|
SHFolder, ShlObj, PSAPI, ShellAPI, ComObj;
|
|
|
|
type
|
|
TShow508MessageIcon = (smiNone, smiInfo, smiWarning, smiError, smiQuestion);
|
|
TShow508MessageButton = (smbOK, smbOKCancel, smbAbortRetryCancel, smbYesNoCancel,
|
|
smbYesNo, smbRetryCancel);
|
|
TShow508MessageResult = (smrOK, srmCancel, smrAbort, smrRetry, smrIgnore, smrYes, smrNo);
|
|
|
|
function ShowMsg(const Msg, Caption: string; Icon: TShow508MessageIcon = smiNone;
|
|
Buttons: TShow508MessageButton = smbOK): TShow508MessageResult; overload;
|
|
|
|
function Show508Message(Const Msg: String): TShow508MessageResult;
|
|
function ShowMsg(const Msg: string; Icon: TShow508MessageIcon = smiNone;
|
|
Buttons: TShow508MessageButton = smbOK): TShow508MessageResult; overload;
|
|
|
|
const
|
|
SHARE_DIR = '\VISTA\Common Files\';
|
|
|
|
{ returns the Nth piece (PieceNum) of a string delimited by Delim }
|
|
function Piece(const S: string; Delim: char; PieceNum: Integer): string;
|
|
{ returns several contiguous pieces }
|
|
function Pieces(const S: string; Delim: char; FirstNum, LastNum: Integer): string;
|
|
|
|
// Same as FreeAndNil, but for TString objects only
|
|
// Frees any objects in the TStrings Objects list as well the TStrings object
|
|
procedure FreeAndNilTStringsAndObjects(var Strings);
|
|
|
|
// Returns true if a screen reader programm is running
|
|
function ScreenReaderActive: boolean;
|
|
|
|
// Special Coding for Screen Readers only enabled if screen reader was
|
|
// running when the application first started up
|
|
function ScreenReaderSupportEnabled: boolean;
|
|
|
|
// Returns C:\...\subPath\File format based on maxSize and Canvas font setting
|
|
function GetFileWithShortenedPath(FileName: String; MaxSize: integer; Canvas: TCanvas): string;
|
|
|
|
const
|
|
HexChars: array[0..255] of string =
|
|
('00','01','02','03','04','05','06','07','08','09','0A','0B','0C','0D','0E','0F',
|
|
'10','11','12','13','14','15','16','17','18','19','1A','1B','1C','1D','1E','1F',
|
|
'20','21','22','23','24','25','26','27','28','29','2A','2B','2C','2D','2E','2F',
|
|
'30','31','32','33','34','35','36','37','38','39','3A','3B','3C','3D','3E','3F',
|
|
'40','41','42','43','44','45','46','47','48','49','4A','4B','4C','4D','4E','4F',
|
|
'50','51','52','53','54','55','56','57','58','59','5A','5B','5C','5D','5E','5F',
|
|
'60','61','62','63','64','65','66','67','68','69','6A','6B','6C','6D','6E','6F',
|
|
'70','71','72','73','74','75','76','77','78','79','7A','7B','7C','7D','7E','7F',
|
|
'80','81','82','83','84','85','86','87','88','89','8A','8B','8C','8D','8E','8F',
|
|
'90','91','92','93','94','95','96','97','98','99','9A','9B','9C','9D','9E','9F',
|
|
'A0','A1','A2','A3','A4','A5','A6','A7','A8','A9','AA','AB','AC','AD','AE','AF',
|
|
'B0','B1','B2','B3','B4','B5','B6','B7','B8','B9','BA','BB','BC','BD','BE','BF',
|
|
'C0','C1','C2','C3','C4','C5','C6','C7','C8','C9','CA','CB','CC','CD','CE','CF',
|
|
'D0','D1','D2','D3','D4','D5','D6','D7','D8','D9','DA','DB','DC','DD','DE','DF',
|
|
'E0','E1','E2','E3','E4','E5','E6','E7','E8','E9','EA','EB','EC','ED','EE','EF',
|
|
'F0','F1','F2','F3','F4','F5','F6','F7','F8','F9','FA','FB','FC','FD','FE','FF');
|
|
|
|
DigitTable = '0123456789ABCDEF';
|
|
|
|
BinChars: array[0..15] of string =
|
|
('0000', // 0
|
|
'0001', // 1
|
|
'0010', // 2
|
|
'0011', // 3
|
|
'0100', // 4
|
|
'0101', // 5
|
|
'0110', // 6
|
|
'0111', // 7
|
|
'1000', // 8
|
|
'1001', // 9
|
|
'1010', // 10
|
|
'1011', // 11
|
|
'1100', // 12
|
|
'1101', // 13
|
|
'1110', // 14
|
|
'1111');// 15
|
|
|
|
type
|
|
TFastIntHexRec = record
|
|
case integer of
|
|
1: (lw: longword);
|
|
2: (b1, b2, b3, b4: byte);
|
|
end;
|
|
|
|
TFastWordHexRec = record
|
|
case integer of
|
|
1: (w: word);
|
|
2: (b1, b2: byte);
|
|
end;
|
|
|
|
// returns an 8 digit hex number
|
|
function FastIntToHex(Value: LongWord): String;
|
|
|
|
// returns an 4 digit hex number
|
|
function FastWordToHex(Value: Word): String;
|
|
|
|
// takes only a 2 digit value - 1 byte - from above table
|
|
function FastHexToByte(HexString: string): byte;
|
|
|
|
// takes only an 8 digit value - 4 bytes
|
|
function FastHexToInt(HexString: string): LongWord;
|
|
|
|
// converts am upper case hex string of any length to binary
|
|
function FastHexToBinary(HexString: string): string;
|
|
|
|
{ returns a cyclic redundancy check for a string }
|
|
function CRCForString(AString: string): DWORD;
|
|
|
|
// If the string parameter does not end with a back slash, one is appended to the end
|
|
// typically used for file path processing
|
|
function AppendBackSlash(var txt: string): string;
|
|
|
|
// returns special folder path on the current machine - such as Program Files etc
|
|
// the parameter is a CSIDL windows constant
|
|
function GetSpecialFolderPath(SpecialFolderCSIDL: integer): String;
|
|
|
|
// returns Program Files path on current machine
|
|
function GetProgramFilesPath: String;
|
|
|
|
// returns Program Files path on the drive where the currently running application
|
|
// resides, if it is a different drive than the one that contains the current
|
|
// machine's Program Files directory. This is typically used for networked drives.
|
|
function GetAlternateProgramFilesPath: String;
|
|
|
|
// Get the Window title (Caption) of a window, given only it's handle
|
|
function GetWindowTitle(Handle: HWND): String;
|
|
|
|
// Get the Window class name string, given only it's window handle
|
|
function GetWindowClassName(Handle: HWND): String;
|
|
|
|
// Add or Remove a message handler to manage custom messages for an existing TWinControl
|
|
type
|
|
// TVAWinProcMessageEvent is used for raw windows messages not intercepted by the controls
|
|
(*
|
|
// doesn't work when the component's parent is changed, or anything else causes the
|
|
handle to be recreated.
|
|
TVAWinProcMessageEvent = function(hWnd: HWND; Msg: UINT;
|
|
wParam: WPARAM; lParam: LPARAM; var Handled: boolean): LRESULT of object;
|
|
*)
|
|
|
|
// TVAMessageEvent is used for windows messages that are intercepted by controls and are
|
|
// converted to TMessage records - messages not intercepted in this manner should be
|
|
// caught by TVAWinProcMessageEvent. Note that this is a different event structure
|
|
// than the TMessageEvent used by TApplication, this uses TMessage rather than TMsg.
|
|
TVAMessageEvent = procedure (var Msg: TMessage; var Handled: Boolean) of object;
|
|
|
|
//procedure AddMessageHandler(Control: TWinControl; MessageHandler: TVAWinProcMessageEvent); overload;
|
|
procedure AddMessageHandler(Control: TWinControl; MessageHandler: TVAMessageEvent); overload;
|
|
|
|
//procedure RemoveMessageHandler(Control: TWinControl; MessageHandler: TVAWinProcMessageEvent); overload;
|
|
procedure RemoveMessageHandler(Control: TWinControl; MessageHandler: TVAMessageEvent); overload;
|
|
|
|
// removes all message handlers, both TVAWinProcMessageEvent and TVAMessageEvent types
|
|
procedure RemoveAllMessageHandlers(Control: TWinControl);
|
|
|
|
function MessageHandlerCount(Control: TWinControl): integer;
|
|
|
|
function GetInstanceCount(ApplicationNameAndPath: string): integer; overload;
|
|
function GetInstanceCount: integer; overload;
|
|
|
|
function AnotherInstanceRunning: boolean;
|
|
|
|
procedure VersionStringSplit(const VerStr: string; var Val1: integer); overload;
|
|
procedure VersionStringSplit(const VerStr: string; var Val1, Val2: integer); overload;
|
|
procedure VersionStringSplit(const VerStr: string; var Val1, Val2, Val3: integer); overload;
|
|
procedure VersionStringSplit(const VerStr: string; var Val1, Val2, Val3, Val4: integer); overload;
|
|
|
|
function ExecuteAndWait(FileName: string; Parameters: String = ''): integer;
|
|
|
|
// when called inside a DLL, returns the fully qualified name of the DLL file
|
|
// must pass an address or a class or procedure that's been defined inside the DLL
|
|
function GetDLLFileName(Address: Pointer): string;
|
|
|
|
const
|
|
{ values that can be passed to FileVersionValue }
|
|
FILE_VER_COMPANYNAME = 'CompanyName';
|
|
FILE_VER_FILEDESCRIPTION = 'FileDescription';
|
|
FILE_VER_FILEVERSION = 'FileVersion';
|
|
FILE_VER_INTERNALNAME = 'InternalName';
|
|
FILE_VER_LEGALCOPYRIGHT = 'LegalCopyright';
|
|
FILE_VER_ORIGINALFILENAME = 'OriginalFilename';
|
|
FILE_VER_PRODUCTNAME = 'ProductName';
|
|
FILE_VER_PRODUCTVERSION = 'ProductVersion';
|
|
FILE_VER_COMMENTS = 'Comments';
|
|
|
|
function FileVersionValue(const AFileName, AValueName: string): string;
|
|
|
|
// compares up to 4 pieces of a numeric version, returns true if CheckVersion is >= OriginalVersion
|
|
// allows for . and , delimited version numbers
|
|
function VersionOK(OriginalVersion, CheckVersion: string): boolean;
|
|
|
|
implementation
|
|
|
|
function Piece(const S: string; Delim: char; PieceNum: Integer): string;
|
|
{ returns the Nth piece (PieceNum) of a string delimited by Delim }
|
|
var
|
|
i: Integer;
|
|
Strt, Next: PChar;
|
|
begin
|
|
i := 1;
|
|
Strt := PChar(S);
|
|
Next := StrScan(Strt, Delim);
|
|
while (i < PieceNum) and (Next <> nil) do
|
|
begin
|
|
Inc(i);
|
|
Strt := Next + 1;
|
|
Next := StrScan(Strt, Delim);
|
|
end;
|
|
if Next = nil then Next := StrEnd(Strt);
|
|
if i < PieceNum then Result := '' else SetString(Result, Strt, Next - Strt);
|
|
end;
|
|
|
|
function Pieces(const S: string; Delim: char; FirstNum, LastNum: Integer): string;
|
|
{ returns several contiguous pieces }
|
|
var
|
|
PieceNum: Integer;
|
|
begin
|
|
Result := '';
|
|
for PieceNum := FirstNum to LastNum do Result := Result + Piece(S, Delim, PieceNum) + Delim;
|
|
if Length(Result) > 0 then Delete(Result, Length(Result), 1);
|
|
end;
|
|
|
|
//type
|
|
// TShow508MessageIcon = (smiNone, smiInfo, smiWarning, smiError, smiQuestion);
|
|
// TShow508MessageButton = (smbOK, smbOKCancel, smbAbortRetryCancel, smbYesNoCancel,
|
|
// smbYesNo, smbRetryCancel);
|
|
// TShow508MessageResult = (smrOK, srmCancel, smrAbort, smrRetry, smrIgnore, smrYes, smrNo);
|
|
|
|
function ShowMsg(const Msg, Caption: string; Icon: TShow508MessageIcon = smiNone;
|
|
Buttons: TShow508MessageButton = smbOK): TShow508MessageResult; overload;
|
|
var
|
|
Flags, Answer: Longint;
|
|
Title: string;
|
|
begin
|
|
Flags := MB_TOPMOST;
|
|
case Icon of
|
|
smiInfo: Flags := Flags OR MB_ICONINFORMATION;
|
|
smiWarning: Flags := Flags OR MB_ICONWARNING;
|
|
smiError: Flags := Flags OR MB_ICONERROR;
|
|
smiQuestion: Flags := Flags OR MB_ICONQUESTION;
|
|
end;
|
|
case Buttons of
|
|
smbOK: Flags := Flags OR MB_OK;
|
|
smbOKCancel: Flags := Flags OR MB_OKCANCEL;
|
|
smbAbortRetryCancel: Flags := Flags OR MB_ABORTRETRYIGNORE;
|
|
smbYesNoCancel: Flags := Flags OR MB_YESNOCANCEL;
|
|
smbYesNo: Flags := Flags OR MB_YESNO;
|
|
smbRetryCancel: Flags := Flags OR MB_RETRYCANCEL;
|
|
end;
|
|
Title := Caption;
|
|
if Title = '' then
|
|
Title := Application.Title;
|
|
Answer := Application.MessageBox(PChar(Msg), PChar(Title), Flags);
|
|
case Answer of
|
|
IDCANCEL: Result := srmCancel;
|
|
IDABORT: Result := smrAbort;
|
|
IDRETRY: Result := smrRetry;
|
|
IDIGNORE: Result := smrIgnore;
|
|
IDYES: Result := smrYes;
|
|
IDNO: Result := smrNo;
|
|
else Result := smrOK; // IDOK
|
|
end;
|
|
end;
|
|
|
|
function ShowMsg(const Msg: string; Icon: TShow508MessageIcon = smiNone;
|
|
Buttons: TShow508MessageButton = smbOK): TShow508MessageResult;
|
|
var
|
|
Caption: string;
|
|
begin
|
|
Caption := '';
|
|
case Icon of
|
|
smiWarning: Caption := ' Warning';
|
|
smiError: Caption := ' Error';
|
|
smiQuestion: Caption := ' Inquiry';
|
|
smiInfo: Caption := ' Information';
|
|
end;
|
|
Caption := Application.Title + Caption;
|
|
Result := ShowMsg(Msg, Caption, Icon, Buttons);
|
|
end;
|
|
|
|
function Show508Message(Const Msg: String): TShow508MessageResult;
|
|
begin
|
|
Result := ShowMsg(msg);
|
|
end;
|
|
|
|
|
|
procedure FreeAndNilTStringsAndObjects(var Strings);
|
|
var
|
|
i: integer;
|
|
list: TStrings;
|
|
begin
|
|
list := TStrings(Strings);
|
|
for I := 0 to List.Count - 1 do
|
|
if assigned(list.Objects[i]) then
|
|
list.Objects[i].Free;
|
|
FreeAndNil(list);
|
|
end;
|
|
|
|
|
|
function ScreenReaderActive: boolean;
|
|
var
|
|
ListStateOn : longbool;
|
|
Success: longbool;
|
|
begin
|
|
//Determine if a screen reader is currently being used.
|
|
Success := SystemParametersInfo(SPI_GETSCREENREADER, 0, @ListStateOn,0);
|
|
if Success and ListStateOn then
|
|
Result := TRUE
|
|
else
|
|
Result := FALSE;
|
|
end;
|
|
|
|
var
|
|
CheckScreenReaderSupport: boolean = TRUE;
|
|
uScreenReaderSupportEnabled: boolean = FALSE;
|
|
|
|
function ScreenReaderSupportEnabled: boolean;
|
|
begin
|
|
if CheckScreenReaderSupport then
|
|
begin
|
|
uScreenReaderSupportEnabled := ScreenReaderActive;
|
|
CheckScreenReaderSupport := FALSE;
|
|
end;
|
|
Result := uScreenReaderSupportEnabled;
|
|
end;
|
|
|
|
const
|
|
DOTS = '...';
|
|
DOTS_LEN = Length(DOTS) + 2;
|
|
|
|
// Returns C:\...\subPath\File format based on maxSize and Canvas font setting
|
|
function GetFileWithShortenedPath(FileName: String; MaxSize: integer; Canvas: TCanvas): string;
|
|
var
|
|
len, count, p, first, last: integer;
|
|
|
|
begin
|
|
Result := FileName;
|
|
count := 0;
|
|
p := 0;
|
|
first := 0;
|
|
last := 0;
|
|
|
|
repeat
|
|
p := PosEx('\', Result, p+1);
|
|
if p > 0 then inc(count);
|
|
if first = 0 then
|
|
begin
|
|
first := p;
|
|
last := p+1;
|
|
end;
|
|
until p = 0;
|
|
|
|
repeat
|
|
len := Canvas.TextWidth(Result);
|
|
if (len > MaxSize) and (count > 0) then
|
|
begin
|
|
if count > 1 then
|
|
begin
|
|
p := last;
|
|
while(Result[p] <> '\') do inc(p);
|
|
Result := copy(Result,1,first) + DOTS + copy(Result,p,MaxInt);
|
|
last := first + DOTS_LEN;
|
|
end
|
|
else
|
|
Result := copy(Result, last, MaxInt);
|
|
dec(count);
|
|
end;
|
|
until (len <= MaxSize) or (count < 1);
|
|
end;
|
|
|
|
// returns an 8 digit hex number
|
|
function FastIntToHex(Value: LongWord): String;
|
|
var
|
|
v: TFastIntHexRec;
|
|
begin
|
|
v.lw:= Value;
|
|
Result := HexChars[v.b4] + HexChars[v.b3] + HexChars[v.b2] + HexChars[v.b1];
|
|
end;
|
|
|
|
// returns an 4 digit hex number
|
|
function FastWordToHex(Value: Word): String;
|
|
var
|
|
v: TFastWordHexRec;
|
|
begin
|
|
v.w:= Value;
|
|
Result := HexChars[v.b2] + HexChars[v.b1];
|
|
end;
|
|
|
|
const
|
|
b1Mult = 1;
|
|
b2Mult = b1Mult * 16;
|
|
b3Mult = b2Mult * 16;
|
|
b4Mult = b3Mult * 16;
|
|
b5Mult = b4Mult * 16;
|
|
b6Mult = b5Mult * 16;
|
|
b7Mult = b6Mult * 16;
|
|
b8Mult = b7Mult * 16;
|
|
|
|
// takes only a 2 digit value - 1 byte - from above table
|
|
function FastHexToByte(HexString: string): byte;
|
|
begin
|
|
Result := ((pos(HexString[2], DigitTable) - 1) * b1Mult) +
|
|
((pos(HexString[1], DigitTable) - 1) * b2Mult);
|
|
end;
|
|
|
|
// takes only an 8 digit value - 4 bytes
|
|
function FastHexToInt(HexString: string): LongWord;
|
|
begin
|
|
Result := ((pos(HexString[8], DigitTable) - 1) * b1Mult) +
|
|
((pos(HexString[7], DigitTable) - 1) * b2Mult) +
|
|
((pos(HexString[6], DigitTable) - 1) * b3Mult) +
|
|
((pos(HexString[5], DigitTable) - 1) * b4Mult) +
|
|
((pos(HexString[4], DigitTable) - 1) * b5Mult) +
|
|
((pos(HexString[3], DigitTable) - 1) * b6Mult) +
|
|
((pos(HexString[2], DigitTable) - 1) * b7Mult) +
|
|
((pos(HexString[1], DigitTable) - 1) * b8Mult);
|
|
end;
|
|
|
|
// converts a hex string to binary
|
|
function FastHexToBinary(HexString: string): string;
|
|
var
|
|
i, len, val: integer;
|
|
chr: string;
|
|
begin
|
|
len := length(HexString);
|
|
Result := '';
|
|
for I := 1 to len do
|
|
begin
|
|
chr := HexString[i];
|
|
val := pos(chr, DigitTable);
|
|
if val > 0 then
|
|
Result := Result + BinChars[val-1]
|
|
end;
|
|
end;
|
|
|
|
const
|
|
{ copied from ORFn - table for calculating CRC values }
|
|
CRC32_TABLE: array[0..255] of DWORD =
|
|
($0, $77073096, $EE0E612C, $990951BA, $76DC419, $706AF48F, $E963A535, $9E6495A3,
|
|
$EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988, $9B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
|
|
$1DB71064, $6AB020F2, $F3B97148, $84BE41DE, $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
|
|
$136C9856, $646BA8C0, $FD62F97A, $8A65C9EC, $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
|
|
$3B6E20C8, $4C69105E, $D56041E4, $A2677172, $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
|
|
$35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940, $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
|
|
$26D930AC, $51DE003A, $C8D75180, $BFD06116, $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
|
|
$2802B89E, $5F058808, $C60CD9B2, $B10BE924, $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,
|
|
$76DC4190, $1DB7106, $98D220BC, $EFD5102A, $71B18589, $6B6B51F, $9FBFE4A5, $E8B8D433,
|
|
$7807C9A2, $F00F934, $9609A88E, $E10E9818, $7F6A0DBB, $86D3D2D, $91646C97, $E6635C01,
|
|
$6B6B51F4, $1C6C6162, $856530D8, $F262004E, $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
|
|
$65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C, $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
|
|
$4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2, $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
|
|
$4369E96A, $346ED9FC, $AD678846, $DA60B8D0, $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
|
|
$5005713C, $270241AA, $BE0B1010, $C90C2086, $5768B525, $206F85B3, $B966D409, $CE61E49F,
|
|
$5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4, $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,
|
|
$EDB88320, $9ABFB3B6, $3B6E20C, $74B1D29A, $EAD54739, $9DD277AF, $4DB2615, $73DC1683,
|
|
$E3630B12, $94643B84, $D6D6A3E, $7A6A5AA8, $E40ECF0B, $9309FF9D, $A00AE27, $7D079EB1,
|
|
$F00F9344, $8708A3D2, $1E01F268, $6906C2FE, $F762575D, $806567CB, $196C3671, $6E6B06E7,
|
|
$FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC, $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
|
|
$D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252, $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
|
|
$D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60, $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
|
|
$CB61B38C, $BC66831A, $256FD2A0, $5268E236, $CC0C7795, $BB0B4703, $220216B9, $5505262F,
|
|
$C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04, $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,
|
|
$9B64C2B0, $EC63F226, $756AA39C, $26D930A, $9C0906A9, $EB0E363F, $72076785, $5005713,
|
|
$95BF4A82, $E2B87A14, $7BB12BAE, $CB61B38, $92D28E9B, $E5D5BE0D, $7CDCEFB7, $BDBDF21,
|
|
$86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E, $81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
|
|
$88085AE6, $FF0F6A70, $66063BCA, $11010B5C, $8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
|
|
$A00AE278, $D70DD2EE, $4E048354, $3903B3C2, $A7672661, $D06016F7, $4969474D, $3E6E77DB,
|
|
$AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0, $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
|
|
$BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6, $BAD03605, $CDD70693, $54DE5729, $23D967BF,
|
|
$B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94, $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);
|
|
|
|
{ returns a cyclic redundancy check for a string }
|
|
function CRCForString(AString: string): DWORD;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result:=$FFFFFFFF;
|
|
for i := 1 to Length(AString) do
|
|
Result:=((Result shr 8) and $00FFFFFF) xor
|
|
CRC32_TABLE[(Result xor Ord(AString[i])) and $000000FF];
|
|
end;
|
|
|
|
function AppendBackSlash(var txt: string): string;
|
|
begin
|
|
if RightStr(txt,1) <> '\' then
|
|
txt := txt + '\';
|
|
Result := txt;
|
|
end;
|
|
|
|
// returns special folder path on the current machine - such as Program Files etc
|
|
// the parameter is a CSIDL windows constant
|
|
function GetSpecialFolderPath(SpecialFolderCSIDL: integer): String;
|
|
var
|
|
Path: array[0..Max_Path] of Char;
|
|
begin
|
|
Path := '';
|
|
SHGetSpecialFolderPath(0, Path, SpecialFolderCSIDL, false);
|
|
Result := Path;
|
|
AppendBackSlash(Result);
|
|
end;
|
|
|
|
// returns Program Files path on current machine
|
|
function GetProgramFilesPath: String;
|
|
begin
|
|
Result := GetSpecialFolderPath(CSIDL_PROGRAM_FILES);
|
|
end;
|
|
|
|
// returns Program Files path on the drive where the currently running application
|
|
// resides, if it is a different drive than the one that contains the current
|
|
// machine's Program Files directory. This is typically used for networked drives.
|
|
// Note that tnis only works if the mapping to the network is at the root drive
|
|
function GetAlternateProgramFilesPath: String;
|
|
var
|
|
Dir, Dir2: string;
|
|
|
|
begin
|
|
Dir := GetProgramFilesPath;
|
|
Dir2 := ExtractFileDrive(Application.ExeName);
|
|
AppendBackSlash(Dir2);
|
|
Dir2 := Dir2 + 'Program Files\';
|
|
If (UpperCase(Dir) = UpperCase(Dir2)) then
|
|
Result := ''
|
|
else
|
|
Result := Dir2;
|
|
end;
|
|
|
|
// Get the Window title (Caption) of a window, given only it's handle
|
|
function GetWindowTitle(Handle: HWND): String;
|
|
begin
|
|
SetLength(Result, 240);
|
|
SetLength(Result, GetWindowText(Handle, PChar(Result), Length(Result)));
|
|
end;
|
|
|
|
function GetWindowClassName(Handle: HWND): String;
|
|
begin
|
|
SetLength(Result, 240);
|
|
SetLength(Result, GetClassName(Handle, PChar(Result), Length(Result)));
|
|
end;
|
|
|
|
type
|
|
(*
|
|
TVACustomWinProcInterceptor = class
|
|
private
|
|
FOldWinProc: Pointer;
|
|
FHexHandle: string;
|
|
FComponent: TWinControl;
|
|
procedure Initialize;
|
|
protected
|
|
constructor Create(Component: TWinControl); virtual;
|
|
function NewWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; virtual;
|
|
// property OldWindowProc: Pointer read FOldWinProc;
|
|
// property Component: TWinControl read FComponent;
|
|
public
|
|
destructor Destroy; override;
|
|
end;
|
|
*)
|
|
(*
|
|
TVAWinProcMessageHandler = class(TVACustomWinProcInterceptor)
|
|
private
|
|
FMessageHandlerList: TVAMethodList;
|
|
function DoMessageHandlers(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM; var MessageHandled: boolean): LRESULT;
|
|
protected
|
|
constructor Create(Component: TWinControl); override;
|
|
function NewWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; override;
|
|
public
|
|
destructor Destroy; override;
|
|
function HandlerCount: integer;
|
|
procedure AddMessageHandler(event: TVAWinProcMessageEvent);
|
|
procedure RemoveMessageHandler(event: TVAWinProcMessageEvent);
|
|
end;
|
|
*)
|
|
|
|
TVACustomMessageEventInterceptor = class
|
|
private
|
|
FOldWndMethod: TWndMethod;
|
|
FComponent: TWinControl;
|
|
protected
|
|
constructor Create(Component: TWinControl); virtual;
|
|
procedure NewMessageHandler(var Message: TMessage); virtual;
|
|
// property OldWndMethod: TWndMethod read FOldWndMethod;
|
|
// property Component: TWinControl read FComponent;
|
|
public
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
TVAMessageEventHandler = class(TVACustomMessageEventInterceptor)
|
|
private
|
|
FMessageHandlerList: TVAMethodList;
|
|
procedure DoMessageHandlers(var Message: TMessage; var MessageHandled: boolean);
|
|
protected
|
|
constructor Create(Component: TWinControl); override;
|
|
procedure NewMessageHandler(var Message: TMessage); override;
|
|
public
|
|
destructor Destroy; override;
|
|
function HandlerCount: integer;
|
|
procedure AddMessageHandler(event: TVAMessageEvent);
|
|
procedure RemoveMessageHandler(event: TVAMessageEvent);
|
|
end;
|
|
|
|
(*
|
|
TVAWinProcAccessClass = class(TWinControl)
|
|
public
|
|
property DefWndProc;
|
|
end;
|
|
*)
|
|
|
|
TVAWinProcMonitor = class(TComponent)
|
|
protected
|
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
|
public
|
|
procedure RemoveFromList(AComponent: TComponent);
|
|
end;
|
|
|
|
|
|
var
|
|
// uWinProcMessageHandlers: TStringList = nil;
|
|
uEventMessageHandlers: TStringList = nil;
|
|
uHandlePointers: TStringlist = nil;
|
|
uWinProcMonitor: TVAWinProcMonitor = nil;
|
|
uMessageHandlerSystemRunning: boolean = FALSE;
|
|
|
|
procedure InitializeMessageHandlerSystem;
|
|
begin
|
|
if not uMessageHandlerSystemRunning then
|
|
begin
|
|
// uWinProcMessageHandlers := TStringList.Create;
|
|
// uWinProcMessageHandlers.Sorted := TRUE;
|
|
// uWinProcMessageHandlers.Duplicates := dupAccept;
|
|
uEventMessageHandlers := TStringList.Create;
|
|
uEventMessageHandlers.Sorted := TRUE;
|
|
uEventMessageHandlers.Duplicates := dupAccept;
|
|
uHandlePointers := TStringList.Create;
|
|
uHandlePointers.Sorted := TRUE; // allows for faster binary searching
|
|
uHandlePointers.Duplicates := dupAccept;
|
|
uWinProcMonitor := TVAWinProcMonitor.Create(nil);
|
|
uMessageHandlerSystemRunning := TRUE;
|
|
end;
|
|
end;
|
|
|
|
procedure CleanupMessageHandlerSystem;
|
|
|
|
procedure Clear(var list: TStringList; FreeObjects: boolean = false);
|
|
var
|
|
i: integer;
|
|
begin
|
|
if assigned(list) then
|
|
begin
|
|
if FreeObjects then
|
|
begin
|
|
for I := 0 to list.Count - 1 do
|
|
list.Objects[i].Free;
|
|
end;
|
|
FreeAndNil(list);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
// Clear(uWinProcMessageHandlers, TRUE);
|
|
Clear(uEventMessageHandlers, TRUE);
|
|
Clear(uHandlePointers);
|
|
if assigned(uWinProcMonitor) then
|
|
FreeAndNil(uWinProcMonitor);
|
|
uMessageHandlerSystemRunning := FALSE;
|
|
end;
|
|
|
|
(*
|
|
procedure AddMessageHandler(Control: TWinControl; MessageHandler: TVAWinProcMessageEvent);
|
|
var
|
|
HexID: string;
|
|
idx: integer;
|
|
Handler: TVAWinProcMessageHandler;
|
|
|
|
begin
|
|
InitializeMessageHandlerSystem;
|
|
HexID := FastIntToHex(LongWord(Control));
|
|
idx := uWinProcMessageHandlers.IndexOf(HexID);
|
|
if idx < 0 then
|
|
begin
|
|
Handler := TVAWinProcMessageHandler.Create(Control);
|
|
uWinProcMessageHandlers.AddObject(HexID, Handler);
|
|
end
|
|
else
|
|
Handler := TVAWinProcMessageHandler(uWinProcMessageHandlers.Objects[idx]);
|
|
Handler.AddMessageHandler(MessageHandler);
|
|
end;
|
|
*)
|
|
|
|
procedure AddMessageHandler(Control: TWinControl; MessageHandler: TVAMessageEvent);
|
|
var
|
|
HexID: string;
|
|
idx: integer;
|
|
Handler: TVAMessageEventHandler;
|
|
|
|
begin
|
|
InitializeMessageHandlerSystem;
|
|
HexID := FastIntToHex(LongWord(Control));
|
|
idx := uEventMessageHandlers.IndexOf(HexID);
|
|
if idx < 0 then
|
|
begin
|
|
Handler := TVAMessageEventHandler.Create(Control);
|
|
uEventMessageHandlers.AddObject(HexID, Handler);
|
|
end
|
|
else
|
|
Handler := TVAMessageEventHandler(uEventMessageHandlers.Objects[idx]);
|
|
Handler.AddMessageHandler(MessageHandler);
|
|
end;
|
|
|
|
(*
|
|
procedure RemoveMessageHandler(Control: TWinControl;
|
|
MessageHandler: TVAWinProcMessageEvent);
|
|
var
|
|
HexID: string;
|
|
idx: integer;
|
|
Handler: TVAWinProcMessageHandler;
|
|
|
|
begin
|
|
if not uMessageHandlerSystemRunning then exit;
|
|
HexID := FastIntToHex(LongWord(Control));
|
|
idx := uWinProcMessageHandlers.IndexOf(HexID);
|
|
if idx >= 0 then
|
|
begin
|
|
Handler := TVAWinProcMessageHandler(uWinProcMessageHandlers.Objects[idx]);
|
|
Handler.RemoveMessageHandler(MessageHandler);
|
|
if Handler.HandlerCount = 0 then
|
|
begin
|
|
Handler.Free;
|
|
uWinProcMessageHandlers.Delete(idx);
|
|
end;
|
|
end;
|
|
end;
|
|
*)
|
|
|
|
procedure RemoveMessageHandler(Control: TWinControl; MessageHandler: TVAMessageEvent);
|
|
var
|
|
HexID: string;
|
|
idx: integer;
|
|
Handler: TVAMessageEventHandler;
|
|
|
|
begin
|
|
if not uMessageHandlerSystemRunning then exit;
|
|
HexID := FastIntToHex(LongWord(Control));
|
|
idx := uEventMessageHandlers.IndexOf(HexID);
|
|
if idx >= 0 then
|
|
begin
|
|
Handler := TVAMessageEventHandler(uEventMessageHandlers.Objects[idx]);
|
|
Handler.RemoveMessageHandler(MessageHandler);
|
|
if Handler.HandlerCount = 0 then
|
|
begin
|
|
Handler.Free;
|
|
uEventMessageHandlers.Delete(idx);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure RemoveAllMessageHandlers(Control: TWinControl);
|
|
var
|
|
HexID: string;
|
|
idx: integer;
|
|
// Handler: TVAWinProcMessageHandler;
|
|
EventHandler: TVAMessageEventHandler;
|
|
|
|
begin
|
|
if not uMessageHandlerSystemRunning then exit;
|
|
HexID := FastIntToHex(LongWord(Control));
|
|
|
|
(*
|
|
idx := uWinProcMessageHandlers.IndexOf(HexID);
|
|
|
|
if idx >= 0 then
|
|
begin
|
|
Handler := TVAWinProcMessageHandler(uWinProcMessageHandlers.Objects[idx]);
|
|
Handler.Free;
|
|
uWinProcMessageHandlers.Delete(idx);
|
|
end;
|
|
*)
|
|
|
|
idx := uEventMessageHandlers.IndexOf(HexID);
|
|
if idx >= 0 then
|
|
begin
|
|
EventHandler := TVAMessageEventHandler(uEventMessageHandlers.Objects[idx]);
|
|
EventHandler.Free;
|
|
uEventMessageHandlers.Delete(idx);
|
|
end;
|
|
|
|
Control.RemoveFreeNotification(uWinProcMonitor);
|
|
end;
|
|
|
|
function MessageHandlerCount(Control: TWinControl): integer;
|
|
var
|
|
HexID: string;
|
|
idx: integer;
|
|
// Handler: TVAWinProcMessageHandler;
|
|
EventHandler: TVAMessageEventHandler;
|
|
|
|
begin
|
|
Result := 0;
|
|
if not uMessageHandlerSystemRunning then exit;
|
|
|
|
HexID := FastIntToHex(LongWord(Control));
|
|
|
|
(* idx := uWinProcMessageHandlers.IndexOf(HexID);
|
|
|
|
if idx >= 0 then
|
|
begin
|
|
Handler := TVAWinProcMessageHandler(uWinProcMessageHandlers.Objects[idx]);
|
|
result := Handler.HandlerCount;
|
|
end;
|
|
*)
|
|
|
|
idx := uEventMessageHandlers.IndexOf(HexID);
|
|
if idx >= 0 then
|
|
begin
|
|
EventHandler := TVAMessageEventHandler(uEventMessageHandlers.Objects[idx]);
|
|
inc(Result, EventHandler.HandlerCount);
|
|
end;
|
|
end;
|
|
|
|
{ TVACustomWinProc }
|
|
|
|
(*
|
|
constructor TVACustomWinProcInterceptor.Create(Component: TWinControl);
|
|
begin
|
|
if not Assigned(Component) then
|
|
raise EInvalidPointer.Create('Component parameter unassigned');
|
|
FComponent := Component;
|
|
Initialize;
|
|
end;
|
|
|
|
destructor TVACustomWinProcInterceptor.Destroy;
|
|
var
|
|
idx: integer;
|
|
begin
|
|
if Assigned(FComponent) then
|
|
begin
|
|
try
|
|
TVAWinProcAccessClass(FComponent).DefWndProc := FOldWinProc;
|
|
except // just in case FComponent has been destroyed
|
|
end;
|
|
end;
|
|
idx := uHandlePointers.IndexOf(FHexHandle);
|
|
if idx >= 0 then
|
|
uHandlePointers.Delete(idx);
|
|
inherited;
|
|
end;
|
|
|
|
function TVACustomWinProcInterceptor.NewWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
|
|
begin
|
|
{
|
|
if (Msg = SOME_MESSAGE) then
|
|
begin
|
|
...
|
|
Result := S_OK;
|
|
end
|
|
else
|
|
}
|
|
Result := CallWindowProc(FOldWinProc, hWnd, Msg, WParam, LParam);
|
|
end;
|
|
|
|
|
|
function BaseWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
|
|
var
|
|
idx: integer;
|
|
|
|
begin
|
|
idx := uHandlePointers.IndexOf(FastIntToHex(hWnd)); // does binary search on sorted string list
|
|
if idx >= 0 then
|
|
Result := TVACustomWinProcInterceptor(uHandlePointers.Objects[idx]).NewWindowProc(hWnd, Msg, wParam, lParam)
|
|
else
|
|
Result := 0; // should never happen
|
|
end;
|
|
|
|
procedure TVACustomWinProcInterceptor.Initialize;
|
|
var
|
|
idx: integer;
|
|
begin
|
|
InitializeMessageHandlerSystem;
|
|
FComponent.HandleNeeded;
|
|
FHexHandle := FastIntToHex(FComponent.Handle);
|
|
idx := uHandlePointers.IndexOf(FHexHandle);
|
|
if idx < 0 then
|
|
uHandlePointers.AddObject(FHexHandle, Self)
|
|
else
|
|
uHandlePointers.Objects[idx] := Self;
|
|
FComponent.FreeNotification(uWinProcMonitor);
|
|
FOldWinProc := TVAWinProcAccessClass(FComponent).DefWndProc;
|
|
TVAWinProcAccessClass(FComponent).DefWndProc := @BaseWindowProc;
|
|
end;
|
|
*)
|
|
|
|
{ TVAWinProcMonitor }
|
|
|
|
|
|
// assumes object is responsible for deleting instance of TVACustomWinProc
|
|
procedure TVAWinProcMonitor.Notification(AComponent: TComponent;
|
|
Operation: TOperation);
|
|
begin
|
|
inherited;
|
|
if (Operation = opRemove) and (AComponent is TWinControl) then
|
|
RemoveFromList(AComponent);
|
|
end;
|
|
|
|
procedure TVAWinProcMonitor.RemoveFromList(AComponent: TComponent);
|
|
begin
|
|
if AComponent is TWinControl then
|
|
RemoveAllMessageHandlers(TWinControl(AComponent));
|
|
end;
|
|
|
|
|
|
{ TVACustomMessageEventInterceptor }
|
|
|
|
constructor TVACustomMessageEventInterceptor.Create(Component: TWinControl);
|
|
begin
|
|
if not Assigned(Component) then
|
|
raise EInvalidPointer.Create('Component parameter unassigned');
|
|
FComponent := Component;
|
|
FComponent.FreeNotification(uWinProcMonitor);
|
|
FOldWndMethod := FComponent.WindowProc;
|
|
FComponent.WindowProc := NewMessageHandler;
|
|
end;
|
|
|
|
destructor TVACustomMessageEventInterceptor.Destroy;
|
|
begin
|
|
FComponent.WindowProc := FOldWndMethod;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TVACustomMessageEventInterceptor.NewMessageHandler(
|
|
var Message: TMessage);
|
|
begin
|
|
FOldWndMethod(Message);
|
|
end;
|
|
|
|
{ TVAWinProcNotifier }
|
|
|
|
(*
|
|
procedure TVAWinProcMessageHandler.AddMessageHandler(event: TVAWinProcMessageEvent);
|
|
begin
|
|
FMessageHandlerList.Add(TMethod(event));
|
|
end;
|
|
|
|
constructor TVAWinProcMessageHandler.Create(Component: TWinControl);
|
|
begin
|
|
FMessageHandlerList := TVAMethodList.Create;
|
|
inherited Create(Component);
|
|
end;
|
|
|
|
destructor TVAWinProcMessageHandler.Destroy;
|
|
begin
|
|
inherited;
|
|
FMessageHandlerList.Free;
|
|
end;
|
|
|
|
function TVAWinProcMessageHandler.DoMessageHandlers(hWnd: HWND; Msg: UINT;
|
|
wParam: WPARAM; lParam: LPARAM; var MessageHandled: boolean): LRESULT;
|
|
var
|
|
Method: TMethod;
|
|
i: integer;
|
|
begin
|
|
MessageHandled := FALSE;
|
|
Result := 0;
|
|
for i := 0 to FMessageHandlerList.Count - 1 do
|
|
begin
|
|
Method := FMessageHandlerList[i];
|
|
Result := TVAWinProcMessageEvent(Method)(hWnd, Msg, wParam, lParam, MessageHandled);
|
|
if MessageHandled then
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
function TVAWinProcMessageHandler.HandlerCount: integer;
|
|
begin
|
|
Result := FMessageHandlerList.Count;
|
|
end;
|
|
|
|
function TVAWinProcMessageHandler.NewWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM;
|
|
lParam: LPARAM): LRESULT;
|
|
var
|
|
MessageHandled: boolean;
|
|
|
|
begin
|
|
Result := DoMessageHandlers(hWnd, Msg, wParam, lParam, MessageHandled);
|
|
if not MessageHandled then
|
|
Result := CallWindowProc(FOldWinProc, hWnd, Msg, WParam, LParam);
|
|
end;
|
|
|
|
procedure TVAWinProcMessageHandler.RemoveMessageHandler(event: TVAWinProcMessageEvent);
|
|
begin
|
|
FMessageHandlerList.Remove(TMethod(event));
|
|
end;
|
|
*)
|
|
|
|
{ TVAMessageEventHandler }
|
|
|
|
procedure TVAMessageEventHandler.AddMessageHandler(event: TVAMessageEvent);
|
|
begin
|
|
FMessageHandlerList.Add(TMethod(event));
|
|
end;
|
|
|
|
constructor TVAMessageEventHandler.Create(Component: TWinControl);
|
|
begin
|
|
FMessageHandlerList := TVAMethodList.Create;
|
|
inherited Create(Component);
|
|
end;
|
|
|
|
destructor TVAMessageEventHandler.Destroy;
|
|
begin
|
|
inherited;
|
|
FMessageHandlerList.Free;
|
|
end;
|
|
|
|
procedure TVAMessageEventHandler.DoMessageHandlers(var Message: TMessage;
|
|
var MessageHandled: boolean);
|
|
var
|
|
Method: TMethod;
|
|
i: integer;
|
|
|
|
begin
|
|
MessageHandled := FALSE;
|
|
for i := 0 to FMessageHandlerList.Count - 1 do
|
|
begin
|
|
Method := FMessageHandlerList[i];
|
|
TVAMessageEvent(Method)(Message, MessageHandled);
|
|
if MessageHandled then
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
function TVAMessageEventHandler.HandlerCount: integer;
|
|
begin
|
|
Result := FMessageHandlerList.Count;
|
|
end;
|
|
|
|
procedure TVAMessageEventHandler.NewMessageHandler(var Message: TMessage);
|
|
var
|
|
MessageHandled: boolean;
|
|
|
|
begin
|
|
DoMessageHandlers(Message, MessageHandled);
|
|
if not MessageHandled then
|
|
FOldWndMethod(Message);
|
|
end;
|
|
|
|
procedure TVAMessageEventHandler.RemoveMessageHandler(event: TVAMessageEvent);
|
|
begin
|
|
FMessageHandlerList.Remove(TMethod(event));
|
|
end;
|
|
|
|
|
|
|
|
type
|
|
TDataArray = record
|
|
private
|
|
FCapacity: integer;
|
|
procedure SetCapacity(Value: integer);
|
|
public
|
|
Data: array of DWORD;
|
|
Count: integer;
|
|
procedure Clear;
|
|
function Size: integer;
|
|
property Capacity: integer read FCapacity write SetCapacity;
|
|
end;
|
|
|
|
{ TDataArray }
|
|
|
|
procedure TDataArray.Clear;
|
|
begin
|
|
SetCapacity(0);
|
|
SetCapacity(128);
|
|
end;
|
|
|
|
procedure TDataArray.SetCapacity(Value: integer);
|
|
begin
|
|
if FCapacity <> Value then
|
|
begin
|
|
FCapacity := Value;
|
|
SetLength(Data, Value);
|
|
if Count >= Value then
|
|
Count := Value - 1;
|
|
end;
|
|
end;
|
|
|
|
|
|
function TDataArray.Size: integer;
|
|
begin
|
|
Result := FCapacity * SizeOf(DWORD);
|
|
end;
|
|
|
|
var
|
|
PIDList: TDataArray;
|
|
ModuleHandles: TDataArray;
|
|
|
|
function GetInstanceCount(ApplicationNameAndPath: string): integer; overload;
|
|
var
|
|
i, j: DWORD;
|
|
name: string;
|
|
process: THandle;
|
|
Output: DWORD;
|
|
current: string;
|
|
ok: BOOL;
|
|
done: boolean;
|
|
|
|
function ListTooSmall(var Data: TDataArray): boolean;
|
|
var
|
|
ReturnCount: integer;
|
|
begin
|
|
Data.Count := 0;
|
|
ReturnCount := Output div SizeOf(DWORD);
|
|
Result := (ReturnCount >= Data.Capacity);
|
|
if Result then
|
|
Data.Capacity := Data.Capacity * 2
|
|
else
|
|
Data.Count := ReturnCount;
|
|
end;
|
|
|
|
begin
|
|
Result := 0;
|
|
current := UpperCase(ApplicationNameAndPath);
|
|
PIDList.Clear;
|
|
repeat
|
|
done := TRUE;
|
|
ok := EnumProcesses(pointer(PIDList.Data), PIDList.Size, Output);
|
|
if ok and ListTooSmall(PIDList) then
|
|
done := FALSE;
|
|
until done or (not ok);
|
|
if ok then
|
|
begin
|
|
for I := 0 to PIDList.Count - 1 do
|
|
begin
|
|
Process := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, FALSE, PIDList.Data[i]);
|
|
if Process <> 0 then
|
|
begin
|
|
try
|
|
ModuleHandles.Clear;
|
|
repeat
|
|
done := TRUE;
|
|
ok := EnumProcessModules(Process, Pointer(ModuleHandles.Data), ModuleHandles.Size, Output);
|
|
if ok and ListTooSmall(ModuleHandles) then
|
|
done := FALSE;
|
|
until done or (not ok);
|
|
if ok then
|
|
begin
|
|
for j := 0 to ModuleHandles.Count - 1 do
|
|
begin
|
|
SetLength(name, MAX_PATH*2);
|
|
SetLength(name, GetModuleFileNameEx(Process, ModuleHandles.Data[j], PChar(name), MAX_PATH*2));
|
|
name := UpperCase(name);
|
|
if name = current then
|
|
begin
|
|
inc(Result);
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
finally
|
|
CloseHandle(Process);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
PIDList.SetCapacity(0);
|
|
ModuleHandles.SetCapacity(0);
|
|
end;
|
|
|
|
|
|
function GetInstanceCount: integer;
|
|
begin
|
|
Result := GetInstanceCount(ParamStr(0));
|
|
end;
|
|
|
|
function AnotherInstanceRunning: boolean;
|
|
begin
|
|
Result := (GetInstanceCount > 1);
|
|
end;
|
|
|
|
procedure VersionStringSplit(const VerStr: string; var Val1: integer);
|
|
var
|
|
dummy2, dummy3, dummy4: integer;
|
|
begin
|
|
VersionStringSplit(VerStr, Val1, dummy2, dummy3, dummy4);
|
|
end;
|
|
|
|
procedure VersionStringSplit(const VerStr: string; var Val1, Val2: integer);
|
|
var
|
|
dummy3, dummy4: integer;
|
|
begin
|
|
VersionStringSplit(VerStr, Val1, Val2, dummy3, dummy4);
|
|
end;
|
|
|
|
procedure VersionStringSplit(const VerStr: string; var Val1, Val2, Val3: integer);
|
|
var
|
|
dummy4: integer;
|
|
begin
|
|
VersionStringSplit(VerStr, Val1, Val2, Val3, dummy4);
|
|
end;
|
|
|
|
procedure VersionStringSplit(const VerStr: string; var Val1, Val2, Val3, Val4: integer);
|
|
var
|
|
temp: string;
|
|
|
|
function GetNum: integer;
|
|
var
|
|
idx: integer;
|
|
|
|
begin
|
|
idx := pos('.', temp);
|
|
if idx < 1 then
|
|
idx := Length(temp) + 1;
|
|
Result := StrToIntDef(copy(temp, 1, idx-1), 0);
|
|
delete(temp, 1, idx);
|
|
end;
|
|
|
|
begin
|
|
temp := VerStr;
|
|
Val1 := GetNum;
|
|
Val2 := GetNum;
|
|
Val3 := GetNum;
|
|
Val4 := GetNum;
|
|
end;
|
|
|
|
const
|
|
FILE_VER_PREFIX = '\StringFileInfo\';
|
|
// FILE_VER_COMMENTS = '\StringFileInfo\040904E4\Comments';
|
|
|
|
function FileVersionValue(const AFileName, AValueName: string): string;
|
|
type
|
|
TValBuf = array[0..255] of Char;
|
|
PValBuf = ^TValBuf;
|
|
|
|
var
|
|
VerSize, ValSize, AHandle: DWORD;
|
|
VerBuf: Pointer;
|
|
ValBuf: PValBuf;
|
|
Output, Query: string;
|
|
POutput: PChar;
|
|
begin
|
|
Result := '';
|
|
VerSize:=GetFileVersionInfoSize(PChar(AFileName), AHandle);
|
|
if VerSize > 0 then
|
|
begin
|
|
GetMem(VerBuf, VerSize);
|
|
try
|
|
GetFileVersionInfo(PChar(AFileName), AHandle, VerSize, VerBuf);
|
|
VerQueryValue(VerBuf, PChar('\VarFileInfo\Translation'), Pointer(ValBuf), ValSize);
|
|
Query := FILE_VER_PREFIX + IntToHex(LoWord(PLongInt(ValBuf)^),4)+
|
|
IntToHex(HiWord(PLongInt(ValBuf)^),4)+
|
|
'\'+AValueName;
|
|
VerQueryValue(VerBuf, PChar(Query), Pointer(ValBuf), ValSize);
|
|
SetString(Output, ValBuf^, ValSize);
|
|
POutput := PChar(Output);
|
|
Result := POutput;
|
|
finally
|
|
FreeMem(VerBuf);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// compares up to 4 pieces of a numeric version, returns true if CheckVersion is >= OriginalVersion
|
|
// allows for . and , delimited version numbers
|
|
function VersionOK(OriginalVersion, CheckVersion: string): boolean;
|
|
var
|
|
v1, v2, v3, v4, r1, r2, r3, r4: Integer;
|
|
|
|
function GetV(var Version: string): integer;
|
|
var
|
|
idx: integer;
|
|
delim: string;
|
|
begin
|
|
if pos('.', Version) > 0 then
|
|
delim := '.'
|
|
else
|
|
delim := ',';
|
|
idx := pos(delim, version);
|
|
if idx < 1 then
|
|
idx := length(Version) + 1;
|
|
Result := StrToIntDef(copy(version, 1, idx-1), 0);
|
|
delete(version, 1, idx);
|
|
end;
|
|
|
|
procedure parse(const v: string; var p1, p2, p3, p4: integer);
|
|
var
|
|
version: string;
|
|
begin
|
|
version := v;
|
|
p1 := GetV(version);
|
|
p2 := GetV(version);
|
|
p3 := GetV(version);
|
|
p4 := GetV(version);
|
|
end;
|
|
|
|
begin
|
|
parse(OriginalVersion, r1, r2, r3, r4);
|
|
parse(CheckVersion, v1, v2, v3, v4);
|
|
Result := FALSE;
|
|
if v1 > r1 then
|
|
Result := TRUE
|
|
else if v1 = r1 then
|
|
begin
|
|
if v2 > r2 then
|
|
Result := TRUE
|
|
else if v2 = r2 then
|
|
begin
|
|
if v3 > r3 then
|
|
Result := TRUE
|
|
else if v3 = r3 then
|
|
begin
|
|
if v4 >= r4 then
|
|
Result := TRUE
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function ExecuteAndWait(FileName: string; Parameters: String = ''): integer;
|
|
var
|
|
exec, shell: OleVariant;
|
|
line: string;
|
|
|
|
begin
|
|
if copy(FileName,1,1) <> '"' then
|
|
line := '"' + FileName + '"'
|
|
else
|
|
line := FileName;
|
|
if Parameters <> '' then
|
|
line := line + ' ' + Parameters;
|
|
shell := CreateOleObject('WScript.Shell');
|
|
try
|
|
exec := shell.Exec(line);
|
|
try
|
|
While exec.status = 0 do
|
|
Sleep(100);
|
|
Result := Exec.ExitCode;
|
|
finally
|
|
VarClear(exec);
|
|
end;
|
|
finally
|
|
VarClear(shell);
|
|
end;
|
|
end;
|
|
|
|
{
|
|
function ExecuteAndWait(FileName: string; Parameters: String = ''): DWORD;
|
|
var
|
|
SEI:TShellExecuteInfo;
|
|
begin
|
|
FillChar(SEI,SizeOf(SEI),0);
|
|
with SEI do begin
|
|
cbSize:=SizeOf(SEI);
|
|
lpVerb:='open';
|
|
lpFile:=PAnsiChar(FileName);
|
|
lpDirectory := PAnsiChar(ExtractFileDir(FileName));
|
|
if Parameters <> '' then
|
|
lpParameters := PAnsiChar(Parameters);
|
|
nShow:=SW_SHOW;
|
|
fMask:=SEE_MASK_NOCLOSEPROCESS;
|
|
end;
|
|
ShellExecuteEx(@SEI);
|
|
WaitForSingleObject(SEI.hProcess, INFINITE);
|
|
if not GetExitCodeProcess(SEI.hProcess, Result) then
|
|
Result := 0;
|
|
CloseHandle(SEI.hProcess);
|
|
end;
|
|
}
|
|
|
|
// when called inside a DLL, returns the fully qualified name of the DLL file
|
|
// must pass an address or a class or procedure that's been defined inside the DLL
|
|
function GetDLLFileName(Address: Pointer): string;
|
|
var
|
|
ProcessHandle: THandle;
|
|
Output: DWORD;
|
|
i, max: integer;
|
|
ModuleHandles: array[0..1023] of HMODULE;
|
|
info: _MODULEINFO;
|
|
pinfo: LPMODULEINFO;
|
|
adr: Int64;
|
|
|
|
begin
|
|
Result := '';
|
|
ProcessHandle := GetCurrentProcess;
|
|
if EnumProcessModules(ProcessHandle, @ModuleHandles, sizeof(ModuleHandles), output) then
|
|
begin
|
|
adr := Int64(Address);
|
|
max := (output div sizeof(HMODULE))-1;
|
|
pinfo := @info;
|
|
for i := 0 to max do
|
|
begin
|
|
if GetModuleInformation(ProcessHandle, ModuleHandles[i], pinfo, sizeof(_MODULEINFO)) then
|
|
begin
|
|
if (adr > Int64(info.lpBaseOfDll)) and (adr < (Int64(info.lpBaseOfDll) + info.SizeOfImage)) then
|
|
begin
|
|
SetLength(Result, MAX_PATH);
|
|
SetLength(Result, GetModuleFileName(ModuleHandles[i], PChar(Result), Length(Result)));
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
initialization
|
|
ScreenReaderSupportEnabled;
|
|
|
|
finalization
|
|
CleanupMessageHandlerSystem;
|
|
|
|
end.
|
|
|