unit UD2_Utils;
interface
{$IF CompilerVersion >= 25.0}
{$LEGACYIFEND ON}
{$IFEND}
{$INCLUDE 'UserDetect2.inc'}
uses
Windows, SysUtils, Dialogs, ShellAPI, Classes, UD2_Parsing;
const
EXITCODE_OK = 0;
EXITCODE_TASK_NOTHING_MATCHES = 1;
EXITCODE_RUN_FAILURE = 2;
EXITCODE_TASK_NOT_EXISTS = 10;
EXITCODE_INI_NOT_FOUND = 11;
EXITCODE_RUNCMD_SYNTAX_ERROR = 12;
EXITCODE_SYNTAX_ERROR = 13;
type
TArrayOfString = array of string;
TIconFileIdx = record
FileName: string;
IconIndex: integer;
end;
function SplitString(const aSeparator, aString: string; aMax: Integer = 0): TArrayOfString;
function MergeString(ary: TArrayOfString; glue: string): string;
function BetterInterpreteBool(str: string): boolean;
function GetOwnCmdName: string;
function ExpandEnvStr(const szInput: string): string;
procedure UD2_RunCMD(cmd: TUD2Command);
function SplitIconString(IconString: string): TIconFileIdx;
// function GetHTML(AUrl: string): string;
procedure VTS_CheckUpdates(VTSID, CurVer: string);
function FormatOSError(ec: DWORD): string;
function CheckBoolParam(idx: integer; name: string): boolean;
function IndexOf_CS(aStrings: TStrings; aToken: string): Integer;
function UD2_GetThreadErrorMode: DWORD;
function UD2_SetThreadErrorMode(dwNewMode: DWORD; lpOldMode: LPDWORD): BOOL;
function GetFileVersion(const FileName: string=''): string;
implementation
uses
wininet, Forms;
function SplitString(const aSeparator, aString: string; aMax: Integer = 0): TArrayOfString;
// https://stackoverflow.com/a/2626991/3544341
var
i, strt, cnt: Integer;
sepLen: Integer;
procedure AddString(aEnd: Integer = -1);
var
endPos: Integer;
begin
if (aEnd = -1) then
endPos := i
else
endPos := aEnd + 1;
if (strt < endPos) then
result[cnt] := Copy(aString, strt, endPos - strt)
else
result[cnt] := '';
Inc(cnt);
end;
begin
if (aString = '') or (aMax < 0) then
begin
SetLength(result, 0);
EXIT;
end;
if (aSeparator = '') then
begin
SetLength(result, 1);
result[0] := aString;
EXIT;
end;
sepLen := Length(aSeparator);
SetLength(result, (Length(aString) div sepLen) + 1);
i := 1;
strt := i;
cnt := 0;
while (i <= (Length(aString)- sepLen + 1)) do
begin
if (aString[i] = aSeparator[1]) then
if (Copy(aString, i, sepLen) = aSeparator) then
begin
AddString;
if (cnt = aMax) then
begin
SetLength(result, cnt);
EXIT;
end;
Inc(i, sepLen - 1);
strt := i + 1;
end;
Inc(i);
end;
AddString(Length(aString));
SetLength(result, cnt);
end;
function BetterInterpreteBool(str: string): boolean;
resourcestring
LNG_CANNOT_INTERPRETE_BOOL = 'Cannot determinate the boolean value of "%s"';
begin
str := LowerCase(str);
if (str = 'yes') or (str = 'true') or (str = '1') then
result := true
else if (str = 'no') or (str = 'false') or (str = '0') then
result := false
else
raise EConvertError.CreateFmt(LNG_CANNOT_INTERPRETE_BOOL, [str]);
end;
function GetOwnCmdName: string;
begin
result := ParamStr(0);
result := ExtractFileName(result);
result := ChangeFileExt(result, '');
result := UpperCase(result);
end;
function ExpandEnvStr(const szInput: string): string;
// https://stackoverflow.com/a/2833147/3544341
const
MAXSIZE = 32768;
begin
SetLength(Result, MAXSIZE);
SetLength(Result, ExpandEnvironmentStrings(pchar(szInput),
@Result[1],length(Result)));
end;
function FormatOSError(ec: DWORD): string;
resourcestring
LNG_UNKNOWN_ERROR = 'Operating system error %d';
begin
result := SysErrorMessage(ec);
// Some errors have no error message, e.g. error 193 (BAD_EXE_FORMAT) in the German version of Windows 10
if result = '' then result := Format(LNG_UNKNOWN_ERROR, [ec]);
end;
function CheckLastOSCall(AThrowException: boolean): boolean;
var
LastError: Cardinal;
begin
LastError := GetLastError;
result := LastError = 0;
if not result then
begin
if AThrowException then
begin
RaiseLastOSError;
end
else
begin
MessageDlg(FormatOSError(LastError), mtError, [mbOK], 0);
end;
end;
end;
function SplitIconString(IconString: string): TIconFileIdx;
var
p: integer;
begin
p := Pos(',', IconString);
if p = 0 then
begin
result.FileName := IconString;
result.IconIndex := 0;
end
else
begin
result.FileName := ExpandEnvStr(copy(IconString, 0, p-1));
result.IconIndex := StrToInt(Copy(IconString, p+1, Length(IconString)-p));
end;
end;
procedure UD2_RunCMD(cmd: TUD2Command);
// Discussion: https://stackoverflow.com/questions/32802679/acceptable-replacement-for-winexec/32804669#32804669
// Version 1: https://pastebin.com/xQjDmyVe
// --> CreateProcess + ShellExecuteEx
// --> Problem: Run-In-Same-Directory functionality is not possible
// (requires manual command and argument separation)
// Version 2: https://pastebin.com/YpUmF5rd
// --> Splits command and arguments manually, and uses ShellExecute
// --> Problem: error handling wrong
// --> Problem: Run-In-Same-Directory functionality is not implemented
// Current version:
// --> Splits command and arguments manually, and uses ShellExecute
// --> Run-In-Same-Directory functionality is implemented
resourcestring
LNG_INVALID_SYNTAX = 'The command line has an invalid syntax';
var
cmdFile, cmdArgs, cmdDir: string;
p: integer;
sei: TShellExecuteInfo;
cmdLine: string;
begin
// We need a function which does following:
// 1. Replace the Environment strings, e.g. %SystemRoot%
// 2. Runs EXE files with parameters (e.g. "cmd.exe /?")
// 3. Runs EXE files without path (e.g. "calc.exe")
// 4. Runs EXE files without extension (e.g. "calc")
// 5. Runs non-EXE files (e.g. "Letter.doc")
// 6. Commands with white spaces (e.g. "C:\Program Files\xyz.exe") must be enclosed in quotes.
cmdLine := ExpandEnvStr(cmd.executable);
// Split command line from argument list
if Copy(cmdLine, 1, 1) = '"' then
begin
cmdLine := Copy(cmdLine, 2, Length(cmdLine)-1);
p := Pos('"', cmdLine);
if p = 0 then
begin
// No matching quotes
// CreateProcess() handles the whole command line as single file name ("abc -> "abc")
// ShellExecuteEx() does not accept the command line
ExitCode := EXITCODE_RUNCMD_SYNTAX_ERROR;
MessageDlg(LNG_INVALID_SYNTAX, mtError, [mbOK], 0);
Exit;
end;
cmdFile := Copy(cmdLine, 1, p-1);
cmdArgs := Copy(cmdLine, p+2, Length(cmdLine)-p-1);
end
else
begin
p := Pos(' ', cmdLine);
if p = 0 then
begin
cmdFile := cmdLine;
cmdArgs := '';
end
else
begin
cmdFile := Copy(cmdLine, 1, p-1);
cmdArgs := Copy(cmdLine, p+1, Length(cmdLine)-p);
end;
end;
ZeroMemory(@sei, SizeOf(sei));
if cmd.runAsAdmin then
begin
sei.lpVerb := 'runas';
end;
if cmd.runInOwnDirectory then
begin
cmdFile := ExtractFileName(cmdLine);
cmdDir := ExtractFilePath(cmdLine);
end
else
begin
cmdFile := cmdLine;
cmdDir := '';
end;
sei.cbSize := SizeOf(sei);
sei.lpFile := PChar(cmdFile);
{$IFNDEF PREFER_SHELLEXECUTEEX_MESSAGES}
sei.fMask := SEE_MASK_FLAG_NO_UI;
{$ENDIF}
if cmdArgs <> '' then sei.lpParameters := PChar(cmdArgs);
if cmdDir <> '' then sei.lpDirectory := PChar(cmdDir);
sei.nShow := cmd.windowMode;
if ShellExecuteEx(@sei) then Exit;
{$IFNDEF PREFER_SHELLEXECUTEEX_MESSAGES}
if not CheckLastOSCall(false) then ExitCode := EXITCODE_RUN_FAILURE;
{$ENDIF}
end;
(*
function GetHTML(const url: string): string;
var
idhttp :Tidhttp;
begin
idhttp := Tidhttp.Create(nil);
try
result := idhttp.Get(url);
finally
idhttp.Free;
end;
end;
*)
// https://www.delphipraxis.net/post43515.html , fixed , works for Delphi 12 Athens
function GetHTML(AUrl: string): RawByteString;
var
databuffer : array[0..4095] of ansichar; // SIC! ansichar!
ResStr : ansistring; // SIC! ansistring
hSession, hfile: hInternet;
dwindex,dwcodelen,dwread,dwNumber: cardinal;
dwcode : array[1..20] of char;
res : pchar;
Str : pansichar; // SIC! pansichar
begin
ResStr:='';
if (system.pos('http://',lowercase(AUrl))=0) and
(system.pos('https://',lowercase(AUrl))=0) then
AUrl:='http://'+AUrl;
// Hinzugefügt
if Assigned(Application) then Application.ProcessMessages;
hSession:=InternetOpen('InetURL:/1.0',
INTERNET_OPEN_TYPE_PRECONFIG,
nil,
nil,
0);
if assigned(hsession) then
begin
// Hinzugefügt
if Assigned(Application) then application.ProcessMessages;
hfile:=InternetOpenUrl(
hsession,
pchar(AUrl),
nil,
0,
INTERNET_FLAG_RELOAD,
0);
dwIndex := 0;
dwCodeLen := 10;
// Hinzugefügt
if Assigned(Application) then application.ProcessMessages;
HttpQueryInfo(hfile,
HTTP_QUERY_STATUS_CODE,
@dwcode,
dwcodeLen,
dwIndex);
res := pchar(@dwcode);
dwNumber := sizeof(databuffer)-1;
if (res ='200') or (res = '302') then
begin
while (InternetReadfile(hfile,
@databuffer,
dwNumber,
DwRead)) do
begin
// Hinzugefügt
if Assigned(Application) then application.ProcessMessages;
if dwRead =0 then
break;
databuffer[dwread]:=#0;
Str := pansichar(@databuffer);
resStr := resStr + Str;
end;
end
else
ResStr := 'Status:'+AnsiString(res);
if assigned(hfile) then
InternetCloseHandle(hfile);
end;
// Hinzugefügt
if Assigned(Application) then application.ProcessMessages;
InternetCloseHandle(hsession);
Result := resStr;
end;
procedure VTS_CheckUpdates(VTSID, CurVer: string);
resourcestring
(*
LNG_DOWNLOAD_ERR = 'Ein Fehler ist aufgetreten. Wahrscheinlich ist keine Internetverbindung aufgebaut, oder der der ViaThinkSoft-Server temporär offline.';
LNG_NEW_VERSION = 'Eine neue Programmversion ist vorhanden. Möchten Sie diese jetzt herunterladen?';
LNG_NO_UPDATE = 'Es ist keine neue Programmversion vorhanden.';
*)
LNG_DOWNLOAD_ERR = 'An error occurred while searching for updates. Please check your internet connection and firewall.';
LNG_NEW_VERSION = 'A new version is available. Do you want to download it now?';
LNG_NO_UPDATE = 'You already have the newest program version.';
var
status: RawByteString;
begin
status := GetHTML('https://www.viathinksoft.de/update/?id='+VTSID);
if Copy(status, 0, 7) = 'Status:' then
begin
MessageDlg(LNG_DOWNLOAD_ERR, mtError, [mbOK], 0);
end
else
begin
if string(status) <> CurVer then
begin
if MessageDlg(LNG_NEW_VERSION, mtConfirmation, mbYesNoCancel, 0) = ID_YES then
begin
shellexecute(application.handle, 'open', pchar('https://www.viathinksoft.de/update/?id=@'+VTSID), '', '', SW_Normal);
end;
end
else
begin
MessageDlg(LNG_NO_UPDATE, mtInformation, [mbOk], 0);
end;
end;
end;
function CheckBoolParam(idx: integer; name: string): boolean;
begin
Result := ('/'+LowerCase(name) = LowerCase(ParamStr(idx))) or
('-'+LowerCase(name) = LowerCase(ParamStr(idx)));
end;
// function GetThreadErrorMode: DWORD; stdcall; external kernel32 name 'GetThreadErrorMode';
function UD2_GetThreadErrorMode: DWORD;
type
TFuncGetThreadErrorMode = function: DWORD; stdcall;
var
dllHandle: Cardinal;
fGetThreadErrorMode: TFuncGetThreadErrorMode;
begin
dllHandle := LoadLibrary(kernel32);
if dllHandle = 0 then
begin
result := 0;
Exit;
end;
try
@fGetThreadErrorMode := GetProcAddress(dllHandle, 'GetThreadErrorMode');
if not Assigned(fGetThreadErrorMode) then
begin
result := 0; // Windows Vista and prior
Exit;
end;
result := fGetThreadErrorMode();
finally
FreeLibrary(dllHandle);
end;
end;
// function SetThreadErrorMode(dwNewMode: DWORD; lpOldMode: LPDWORD): BOOL; stdcall; external kernel32 name 'SetThreadErrorMode';
function UD2_SetThreadErrorMode(dwNewMode: DWORD; lpOldMode: LPDWORD): BOOL;
type
TFuncSetThreadErrorMode = function(dwNewMode: DWORD; lpOldMode: LPDWORD): BOOL; stdcall;
var
dllHandle: Cardinal;
fSetThreadErrorMode: TFuncSetThreadErrorMode;
begin
dllHandle := LoadLibrary(kernel32);
if dllHandle = 0 then
begin
result := FALSE;
if Assigned(lpOldMode) then lpOldMode^ := UD2_GetThreadErrorMode;
Exit;
end;
try
@fSetThreadErrorMode := GetProcAddress(dllHandle, 'SetThreadErrorMode');
if not Assigned(fSetThreadErrorMode) then
begin
result := FALSE; // Windows Vista and prior
if Assigned(lpOldMode) then lpOldMode^ := UD2_GetThreadErrorMode;
Exit;
end;
result := fSetThreadErrorMode(dwNewMode, lpOldMode);
finally
FreeLibrary(dllHandle);
end;
end;
function IndexOf_CS(aStrings: TStrings; aToken: String): Integer;
var
i: Integer;
begin
Result := -1;
for i := 0 to aStrings.Count-1 do
begin
if aStrings[i] = aToken then
begin
Result := i;
Break;
end;
end;
end;
function MergeString(ary: TArrayOfString; glue: string): string;
var
i: integer;
begin
result := '';
for i := Low(ary) to High(ary) do
begin
if result <> '' then result := result + glue;
result := result + ary[i];
end;
end;
function GetFileVersion(const FileName: string=''): string;
var
lpVerInfo: pointer;
rVerValue: PVSFixedFileInfo;
dwInfoSize: cardinal;
dwValueSize: cardinal;
dwDummy: cardinal;
lpstrPath: pchar;
a, b, c, d: word;
resourcestring
LNG_NO_VERSION = 'No version specification';
begin
if Trim(FileName) = EmptyStr then
lpstrPath := pchar(ParamStr(0))
else
lpstrPath := pchar(FileName);
dwInfoSize := GetFileVersionInfoSize(lpstrPath, dwDummy);
if dwInfoSize = 0 then
begin
Result := LNG_NO_VERSION;
Exit;
end;
GetMem(lpVerInfo, dwInfoSize);
try
GetFileVersionInfo(lpstrPath, 0, dwInfoSize, lpVerInfo);
VerQueryValue(lpVerInfo, '', pointer(rVerValue), dwValueSize);
with rVerValue^ do
begin
a := dwFileVersionMS shr 16;
b := dwFileVersionMS and $FFFF;
c := dwFileVersionLS shr 16;
d := dwFileVersionLS and $FFFF;
Result := IntToStr(a);
if (b <> 0) or (c <> 0) or (d <> 0) then Result := Result + '.' + IntToStr(b);
if (c <> 0) or (d <> 0) then Result := Result + '.' + IntToStr(c);
if (d <> 0) then Result := Result + '.' + IntToStr(d);
end;
finally
FreeMem(lpVerInfo, dwInfoSize);
end;
end;
end.