WebSVN – userdetect2 – Diff – /trunk/UserDetect2/UD2_Utils.pas


unit UD2_Utils;
 
interface
 
{$IF CompilerVersion >= 25.0}
{$LEGACYIFEND ON}
{$IFEND}
 
{$INCLUDE 'UserDetect2.inc'}
 
 
 
 
uses
  Windows, SysUtils, Dialogs, ShellAPI, Classes;
 
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;
 
const
  // Prefixes for UD2_RunCmd()
  UD2_RUN_IN_OWN_DIRECTORY_PREFIX = '$RIOD$';
  UD2_RUN_AS_ADMIN                = '$ADMIN$';
 
function SplitString(const aSeparator, aString: string; aMax: Integer = 0): TArrayOfString;
function BetterInterpreteBool(str: string): boolean;
function GetOwnCmdName: string;
function ExpandEnvStr(const szInput: string): string;
procedure UD2_RunCMD(cmdLine: string; WindowMode: integer=SW_NORMAL);
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;
 
implementation
 
uses
  WinInet, Forms;
 
function SplitString(const aSeparator, aString: string; aMax: Integer = 0): TArrayOfString;
// http://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;
// http://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(cmdLine: string; WindowMode: integer=SW_NORMAL);
// Discussion: http://stackoverflow.com/questions/32802679/acceptable-replacement-for-winexec/32804669#32804669
// Version 1: http://pastebin.com/xQjDmyVe
// --> CreateProcess + ShellExecuteEx
// --> Problem: Run-In-Same-Directory functionality is not possible
//              (requires manual command and argument separation)
// Version 2: http://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;
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(cmdLine);
 
  // 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 Pos(UD2_RUN_AS_ADMIN, cmdLine) >= 1 then
  begin
    cmdLine := StringReplace(cmdLine, UD2_RUN_AS_ADMIN, '', [rfReplaceAll]);
 
    sei.lpVerb := 'runas';
  end;
 
  if Pos(UD2_RUN_IN_OWN_DIRECTORY_PREFIX, cmdLine) >= 1 then
  begin
    cmdLine := StringReplace(cmdLine, UD2_RUN_IN_OWN_DIRECTORY_PREFIX, '', [rfReplaceAll]);
 
    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        := WindowMode;
  if ShellExecuteEx(@sei) then Exit;
  {$IFNDEF PREFER_SHELLEXECUTEEX_MESSAGES}
  if not CheckLastOSCall(false) then ExitCode := EXITCODE_RUN_FAILURE;
  {$ENDIF}
end;
 
function GetHTML(AUrl: string): string;
// http://www.delphipraxis.net/post43515.html
// Modificated by ViaThinkSoft
var
  databuffer : array[0..4095] of char;
  ResStr : string;
  hSession, hfile: hInternet;
  dwindex,dwcodelen,dwread,dwNumber: cardinal;
  dwcode : array[1..20] of char;
  res    : pchar;
  Str    : pchar;
begin
  ResStr := '';
  if system.pos('http://',lowercase(AUrl)) = 0 then
  begin
     AUrl:='http://'+AUrl;
  end;
 
  // [ViaThinkSoft] Added
  Application.ProcessMessages;
 
  hSession:=InternetOpen('InetURL:/1.0',
                         INTERNET_OPEN_TYPE_PRECONFIG,
                         nil,
                         nil,
                         0);
  if assigned(hsession) then
  begin
    // [ViaThinkSoft] Added
    Application.ProcessMessages;
 
    hfile := InternetOpenUrl(hsession,
                             pchar(AUrl),
                             nil,
                             0,
                             INTERNET_FLAG_RELOAD,
                             0);
    dwIndex   := 0;
    dwCodeLen := 10;
 
    // [ViaThinkSoft] Added
    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
 
        // [ViaThinkSoft] Added
        Application.ProcessMessages;
 
        if dwRead =0 then
          break;
        databuffer[dwread]:=#0;
        Str := pchar(@databuffer);
        resStr := resStr + Str;
      end;
    end
    else
      ResStr := 'Status:'+res;
    if assigned(hfile) then
      InternetCloseHandle(hfile);
  end;
 
  // Hinzugefügt
  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: string;
begin
  status := GetHTML('http://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 status <> CurVer then
    begin
      if MessageDlg(LNG_NEW_VERSION, mtConfirmation, mbYesNoCancel, 0) = ID_YES then
      begin
        shellexecute(application.handle, 'open', pchar('http://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;
// Source: http://www.delphipraxis.net/888928-post15.html
var
  i : Integer;
begin
  Result := -1;
  for i := 0 to aStrings.Count do
    if aStrings[i]=aToken then begin
      Result := i;
      Break;
    end;
end;
 
end.
 

Rev 81	Rev 82
1	unit UD2_Utils;	1	unit UD2_Utils;
2		2
3	interface	3	interface
4		4
5	{$IF CompilerVersion >= 25.0}	5	{$IF CompilerVersion >= 25.0}
6	{$LEGACYIFEND ON}	6	{$LEGACYIFEND ON}
7	{$IFEND}	7	{$IFEND}
8		8
9	{$INCLUDE 'UserDetect2.inc'}	9	{$INCLUDE 'UserDetect2.inc'}
10		10
11	{$WARN UNSAFE_CODE OFF}	-
12	{$WARN UNSAFE_TYPE OFF}	-
13		-
14	uses	11	uses
15	Windows, SysUtils, Dialogs, ShellAPI;	12	Windows, SysUtils, Dialogs, ShellAPI, Classes;
16		13
17	const	14	const
18	EXITCODE_OK = 0;	15	EXITCODE_OK = 0;
19	EXITCODE_TASK_NOTHING_MATCHES = 1;	16	EXITCODE_TASK_NOTHING_MATCHES = 1;
20	EXITCODE_RUN_FAILURE = 2;	17	EXITCODE_RUN_FAILURE = 2;
21	EXITCODE_TASK_NOT_EXISTS = 10;	18	EXITCODE_TASK_NOT_EXISTS = 10;
22	EXITCODE_INI_NOT_FOUND = 11;	19	EXITCODE_INI_NOT_FOUND = 11;
23	EXITCODE_RUNCMD_SYNTAX_ERROR = 12;	20	EXITCODE_RUNCMD_SYNTAX_ERROR = 12;
24	EXITCODE_SYNTAX_ERROR = 13;	21	EXITCODE_SYNTAX_ERROR = 13;
25		22
26	type	23	type
27	TArrayOfString = array of String;	24	TArrayOfString = array of string;
28		25
29	TIconFileIdx = record	26	TIconFileIdx = record
30	FileName: string;	27	FileName: string;
31	IconIndex: integer;	28	IconIndex: integer;
32	end;	29	end;
33		30
34	const	31	const
35	// Prefixes for UD2_RunCmd()	32	// Prefixes for UD2_RunCmd()
36	UD2_RUN_IN_OWN_DIRECTORY_PREFIX = '$RIOD$';	33	UD2_RUN_IN_OWN_DIRECTORY_PREFIX = '$RIOD$';
37	UD2_RUN_AS_ADMIN = '$ADMIN$';	34	UD2_RUN_AS_ADMIN = '$ADMIN$';
38		35
39	function SplitString(const aSeparator, aString: String; aMax: Integer = 0): TArrayOfString;	36	function SplitString(const aSeparator, aString: string; aMax: Integer = 0): TArrayOfString;
40	function BetterInterpreteBool(str: String): boolean;	37	function BetterInterpreteBool(str: string): boolean;
41	function GetOwnCmdName: string;	38	function GetOwnCmdName: string;
42	function ExpandEnvStr(const szInput: string): string;	39	function ExpandEnvStr(const szInput: string): string;
43	procedure UD2_RunCMD(cmdLine: string; WindowMode: integer=SW_NORMAL);	40	procedure UD2_RunCMD(cmdLine: string; WindowMode: integer=SW_NORMAL);
44	function SplitIconString(IconString: string): TIconFileIdx;	41	function SplitIconString(IconString: string): TIconFileIdx;
45	// function GetHTML(AUrl: string): string;	42	// function GetHTML(AUrl: string): string;
46	procedure VTS_CheckUpdates(VTSID, CurVer: string);	43	procedure VTS_CheckUpdates(VTSID, CurVer: string);
47	function FormatOSError(ec: DWORD): string;	44	function FormatOSError(ec: DWORD): string;
48	function CheckBoolParam(idx: integer; name: string): boolean;	45	function CheckBoolParam(idx: integer; name: string): boolean;
-		46	function IndexOf_CS(aStrings: TStrings; aToken: String): Integer;
-		47	function UD2_GetThreadErrorMode: DWORD;
-		48	function UD2_SetThreadErrorMode(dwNewMode: DWORD; lpOldMode: LPDWORD): BOOL;
49		49
50	implementation	50	implementation
51		51
52	uses	52	uses
53	WinInet, Forms;	53	WinInet, Forms;
54		54
55	function SplitString(const aSeparator, aString: String; aMax: Integer = 0): TArrayOfString;	55	function SplitString(const aSeparator, aString: string; aMax: Integer = 0): TArrayOfString;
56	// http://stackoverflow.com/a/2626991/3544341	56	// http://stackoverflow.com/a/2626991/3544341
57	var	57	var
58	i, strt, cnt: Integer;	58	i, strt, cnt: Integer;
59	sepLen: Integer;	59	sepLen: Integer;
60		60
61	procedure AddString(aEnd: Integer = -1);	61	procedure AddString(aEnd: Integer = -1);
62	var	62	var
63	endPos: Integer;	63	endPos: Integer;
64	begin	64	begin
65	if (aEnd = -1) then	65	if (aEnd = -1) then
66	endPos := i	66	endPos := i
67	else	67	else
68	endPos := aEnd + 1;	68	endPos := aEnd + 1;
69		69
70	if (strt < endPos) then	70	if (strt < endPos) then
71	result[cnt] := Copy(aString, strt, endPos - strt)	71	result[cnt] := Copy(aString, strt, endPos - strt)
72	else	72	else
73	result[cnt] := '';	73	result[cnt] := '';
74		74
75	Inc(cnt);	75	Inc(cnt);
76	end;	76	end;
77		77
78	begin	78	begin
79	if (aString = '') or (aMax < 0) then	79	if (aString = '') or (aMax < 0) then
80	begin	80	begin
81	SetLength(result, 0);	81	SetLength(result, 0);
82	EXIT;	82	EXIT;
83	end;	83	end;
84		84
85	if (aSeparator = '') then	85	if (aSeparator = '') then
86	begin	86	begin
87	SetLength(result, 1);	87	SetLength(result, 1);
88	result[0] := aString;	88	result[0] := aString;
89	EXIT;	89	EXIT;
90	end;	90	end;
91		91
92	sepLen := Length(aSeparator);	92	sepLen := Length(aSeparator);
93	SetLength(result, (Length(aString) div sepLen) + 1);	93	SetLength(result, (Length(aString) div sepLen) + 1);
94		94
95	i := 1;	95	i := 1;
96	strt := i;	96	strt := i;
97	cnt := 0;	97	cnt := 0;
98	while (i <= (Length(aString)- sepLen + 1)) do	98	while (i <= (Length(aString)- sepLen + 1)) do
99	begin	99	begin
100	if (aString[i] = aSeparator[1]) then	100	if (aString[i] = aSeparator[1]) then
101	if (Copy(aString, i, sepLen) = aSeparator) then	101	if (Copy(aString, i, sepLen) = aSeparator) then
102	begin	102	begin
103	AddString;	103	AddString;
104		104
105	if (cnt = aMax) then	105	if (cnt = aMax) then
106	begin	106	begin
107	SetLength(result, cnt);	107	SetLength(result, cnt);
108	EXIT;	108	EXIT;
109	end;	109	end;
110		110
111	Inc(i, sepLen - 1);	111	Inc(i, sepLen - 1);
112	strt := i + 1;	112	strt := i + 1;
113	end;	113	end;
114		114
115	Inc(i);	115	Inc(i);
116	end;	116	end;
117		117
118	AddString(Length(aString));	118	AddString(Length(aString));
119		119
120	SetLength(result, cnt);	120	SetLength(result, cnt);
121	end;	121	end;
122		122
123	function BetterInterpreteBool(str: String): boolean;	123	function BetterInterpreteBool(str: string): boolean;
124	resourcestring	124	resourcestring
125	LNG_CANNOT_INTERPRETE_BOOL = 'Cannot determinate the boolean value of "%s"';	125	LNG_CANNOT_INTERPRETE_BOOL = 'Cannot determinate the boolean value of "%s"';
126	begin	126	begin
127	str := LowerCase(str);	127	str := LowerCase(str);
128	if (str = 'yes') or (str = 'true') or (str = '1') then	128	if (str = 'yes') or (str = 'true') or (str = '1') then
129	result := true	129	result := true
130	else if (str = 'no') or (str = 'false') or (str = '0') then	130	else if (str = 'no') or (str = 'false') or (str = '0') then
131	result := false	131	result := false
132	else	132	else
133	raise EConvertError.CreateFmt(LNG_CANNOT_INTERPRETE_BOOL, [str]);	133	raise EConvertError.CreateFmt(LNG_CANNOT_INTERPRETE_BOOL, [str]);
134	end;	134	end;
135		135
136	function GetOwnCmdName: string;	136	function GetOwnCmdName: string;
137	begin	137	begin
138	result := ParamStr(0);	138	result := ParamStr(0);
139	result := ExtractFileName(result);	139	result := ExtractFileName(result);
140	result := ChangeFileExt(result, '');	140	result := ChangeFileExt(result, '');
141	result := UpperCase(result);	141	result := UpperCase(result);
142	end;	142	end;
143		143
144	function ExpandEnvStr(const szInput: string): string;	144	function ExpandEnvStr(const szInput: string): string;
145	// http://stackoverflow.com/a/2833147/3544341	145	// http://stackoverflow.com/a/2833147/3544341
146	const	146	const
147	MAXSIZE = 32768;	147	MAXSIZE = 32768;
148	begin	148	begin
149	SetLength(Result, MAXSIZE);	149	SetLength(Result, MAXSIZE);
150	SetLength(Result, ExpandEnvironmentStrings(pchar(szInput),	150	SetLength(Result, ExpandEnvironmentStrings(pchar(szInput),
151	@Result[1],length(Result)));	151	@Result[1],length(Result)));
152	end;	152	end;
153		153
154	function FormatOSError(ec: DWORD): string;	154	function FormatOSError(ec: DWORD): string;
155	resourcestring	155	resourcestring
156	LNG_UNKNOWN_ERROR = 'Operating system error %d';	156	LNG_UNKNOWN_ERROR = 'Operating system error %d';
157	begin	157	begin
158	result := SysErrorMessage(ec);	158	result := SysErrorMessage(ec);
159		159
160	// Some errors have no error message, e.g. error 193 (BAD_EXE_FORMAT) in the German version of Windows 10	160	// Some errors have no error message, e.g. error 193 (BAD_EXE_FORMAT) in the German version of Windows 10
161	if result = '' then result := Format(LNG_UNKNOWN_ERROR, [ec]);	161	if result = '' then result := Format(LNG_UNKNOWN_ERROR, [ec]);
162	end;	162	end;
163		163
164	function CheckLastOSCall(AThrowException: boolean): boolean;	164	function CheckLastOSCall(AThrowException: boolean): boolean;
165	var	165	var
166	LastError: Cardinal;	166	LastError: Cardinal;
167	begin	167	begin
168	LastError := GetLastError;	168	LastError := GetLastError;
169	result := LastError = 0;	169	result := LastError = 0;
170	if not result then	170	if not result then
171	begin	171	begin
172	if AThrowException then	172	if AThrowException then
173	begin	173	begin
174	RaiseLastOSError;	174	RaiseLastOSError;
175	end	175	end
176	else	176	else
177	begin	177	begin
178	MessageDlg(FormatOSError(LastError), mtError, [mbOK], 0);	178	MessageDlg(FormatOSError(LastError), mtError, [mbOK], 0);
179	end;	179	end;
180	end;	180	end;
181	end;	181	end;
182		182
183	function SplitIconString(IconString: string): TIconFileIdx;	183	function SplitIconString(IconString: string): TIconFileIdx;
184	var	184	var
185	p: integer;	185	p: integer;
186	begin	186	begin
187	p := Pos(',', IconString);	187	p := Pos(',', IconString);
188		188
189	if p = 0 then	189	if p = 0 then
190	begin	190	begin
191	result.FileName := IconString;	191	result.FileName := IconString;
192	result.IconIndex := 0;	192	result.IconIndex := 0;
193	end	193	end
194	else	194	else
195	begin	195	begin
196	result.FileName := ExpandEnvStr(copy(IconString, 0, p-1));	196	result.FileName := ExpandEnvStr(copy(IconString, 0, p-1));
197	result.IconIndex := StrToInt(Copy(IconString, p+1, Length(IconString)-p));	197	result.IconIndex := StrToInt(Copy(IconString, p+1, Length(IconString)-p));
198	end;	198	end;
199	end;	199	end;
200		200
201	procedure UD2_RunCMD(cmdLine: string; WindowMode: integer=SW_NORMAL);	201	procedure UD2_RunCMD(cmdLine: string; WindowMode: integer=SW_NORMAL);
202	// Discussion: http://stackoverflow.com/questions/32802679/acceptable-replacement-for-winexec/32804669#32804669	202	// Discussion: http://stackoverflow.com/questions/32802679/acceptable-replacement-for-winexec/32804669#32804669
203	// Version 1: http://pastebin.com/xQjDmyVe	203	// Version 1: http://pastebin.com/xQjDmyVe
204	// --> CreateProcess + ShellExecuteEx	204	// --> CreateProcess + ShellExecuteEx
205	// --> Problem: Run-In-Same-Directory functionality is not possible	205	// --> Problem: Run-In-Same-Directory functionality is not possible
206	// (requires manual command and argument separation)	206	// (requires manual command and argument separation)
207	// Version 2: http://pastebin.com/YpUmF5rd	207	// Version 2: http://pastebin.com/YpUmF5rd
208	// --> Splits command and arguments manually, and uses ShellExecute	208	// --> Splits command and arguments manually, and uses ShellExecute
209	// --> Problem: error handling wrong	209	// --> Problem: error handling wrong
210	// --> Problem: Run-In-Same-Directory functionality is not implemented	210	// --> Problem: Run-In-Same-Directory functionality is not implemented
211	// Current version:	211	// Current version:
212	// --> Splits command and arguments manually, and uses ShellExecute	212	// --> Splits command and arguments manually, and uses ShellExecute
213	// --> Run-In-Same-Directory functionality is implemented	213	// --> Run-In-Same-Directory functionality is implemented
214	resourcestring	214	resourcestring
215	LNG_INVALID_SYNTAX = 'The command line has an invalid syntax';	215	LNG_INVALID_SYNTAX = 'The command line has an invalid syntax';
216	var	216	var
217	cmdFile, cmdArgs, cmdDir: string;	217	cmdFile, cmdArgs, cmdDir: string;
218	p: integer;	218	p: integer;
219	sei: TShellExecuteInfo;	219	sei: TShellExecuteInfo;
220	begin	220	begin
221	// We need a function which does following:	221	// We need a function which does following:
222	// 1. Replace the Environment strings, e.g. %SystemRoot%	222	// 1. Replace the Environment strings, e.g. %SystemRoot%
223	// 2. Runs EXE files with parameters (e.g. "cmd.exe /?")	223	// 2. Runs EXE files with parameters (e.g. "cmd.exe /?")
224	// 3. Runs EXE files without path (e.g. "calc.exe")	224	// 3. Runs EXE files without path (e.g. "calc.exe")
225	// 4. Runs EXE files without extension (e.g. "calc")	225	// 4. Runs EXE files without extension (e.g. "calc")
226	// 5. Runs non-EXE files (e.g. "Letter.doc")	226	// 5. Runs non-EXE files (e.g. "Letter.doc")
227	// 6. Commands with white spaces (e.g. "C:\Program Files\xyz.exe") must be enclosed in quotes.	227	// 6. Commands with white spaces (e.g. "C:\Program Files\xyz.exe") must be enclosed in quotes.
228		228
229	cmdLine := ExpandEnvStr(cmdLine);	229	cmdLine := ExpandEnvStr(cmdLine);
230		230
231	// Split command line from argument list	231	// Split command line from argument list
232	if Copy(cmdLine, 1, 1) = '"' then	232	if Copy(cmdLine, 1, 1) = '"' then
233	begin	233	begin
234	cmdLine := Copy(cmdLine, 2, Length(cmdLine)-1);	234	cmdLine := Copy(cmdLine, 2, Length(cmdLine)-1);
235	p := Pos('"', cmdLine);	235	p := Pos('"', cmdLine);
236	if p = 0 then	236	if p = 0 then
237	begin	237	begin
238	// No matching quotes	238	// No matching quotes
239	// CreateProcess() handles the whole command line as single file name ("abc -> "abc")	239	// CreateProcess() handles the whole command line as single file name ("abc -> "abc")
240	// ShellExecuteEx() does not accept the command line	240	// ShellExecuteEx() does not accept the command line
241	ExitCode := EXITCODE_RUNCMD_SYNTAX_ERROR;	241	ExitCode := EXITCODE_RUNCMD_SYNTAX_ERROR;
242	MessageDlg(LNG_INVALID_SYNTAX, mtError, [mbOK], 0);	242	MessageDlg(LNG_INVALID_SYNTAX, mtError, [mbOK], 0);
243	Exit;	243	Exit;
244	end;	244	end;
245	cmdFile := Copy(cmdLine, 1, p-1);	245	cmdFile := Copy(cmdLine, 1, p-1);
246	cmdArgs := Copy(cmdLine, p+2, Length(cmdLine)-p-1);	246	cmdArgs := Copy(cmdLine, p+2, Length(cmdLine)-p-1);
247	end	247	end
248	else	248	else
249	begin	249	begin
250	p := Pos(' ', cmdLine);	250	p := Pos(' ', cmdLine);
251	if p = 0 then	251	if p = 0 then
252	begin	252	begin
253	cmdFile := cmdLine;	253	cmdFile := cmdLine;
254	cmdArgs := '';	254	cmdArgs := '';
255	end	255	end
256	else	256	else
257	begin	257	begin
258	cmdFile := Copy(cmdLine, 1, p-1);	258	cmdFile := Copy(cmdLine, 1, p-1);
259	cmdArgs := Copy(cmdLine, p+1, Length(cmdLine)-p);	259	cmdArgs := Copy(cmdLine, p+1, Length(cmdLine)-p);
260	end;	260	end;
261	end;	261	end;
262		262
263	ZeroMemory(@sei, SizeOf(sei));	263	ZeroMemory(@sei, SizeOf(sei));
264		264
265	if Pos(UD2_RUN_AS_ADMIN, cmdLine) >= 1 then	265	if Pos(UD2_RUN_AS_ADMIN, cmdLine) >= 1 then
266	begin	266	begin
267	cmdLine := StringReplace(cmdLine, UD2_RUN_AS_ADMIN, '', [rfReplaceAll]);	267	cmdLine := StringReplace(cmdLine, UD2_RUN_AS_ADMIN, '', [rfReplaceAll]);
268		268
269	sei.lpVerb := 'runas';	269	sei.lpVerb := 'runas';
270	end;	270	end;
271		271
272	if Pos(UD2_RUN_IN_OWN_DIRECTORY_PREFIX, cmdLine) >= 1 then	272	if Pos(UD2_RUN_IN_OWN_DIRECTORY_PREFIX, cmdLine) >= 1 then
273	begin	273	begin
274	cmdLine := StringReplace(cmdLine, UD2_RUN_IN_OWN_DIRECTORY_PREFIX, '', [rfReplaceAll]);	274	cmdLine := StringReplace(cmdLine, UD2_RUN_IN_OWN_DIRECTORY_PREFIX, '', [rfReplaceAll]);
275		275
276	cmdFile := ExtractFileName(cmdLine);	276	cmdFile := ExtractFileName(cmdLine);
277	cmdDir := ExtractFilePath(cmdLine);	277	cmdDir := ExtractFilePath(cmdLine);
278	end	278	end
279	else	279	else
280	begin	280	begin
281	cmdFile := cmdLine;	281	cmdFile := cmdLine;
282	cmdDir := '';	282	cmdDir := '';
283	end;	283	end;
284		284
285	sei.cbSize := SizeOf(sei);	285	sei.cbSize := SizeOf(sei);
286	sei.lpFile := PChar(cmdFile);	286	sei.lpFile := PChar(cmdFile);
287	{$IFNDEF PREFER_SHELLEXECUTEEX_MESSAGES}	287	{$IFNDEF PREFER_SHELLEXECUTEEX_MESSAGES}
288	sei.fMask := SEE_MASK_FLAG_NO_UI;	288	sei.fMask := SEE_MASK_FLAG_NO_UI;
289	{$ENDIF}	289	{$ENDIF}
290	if cmdArgs <> '' then sei.lpParameters := PChar(cmdArgs);	290	if cmdArgs <> '' then sei.lpParameters := PChar(cmdArgs);
291	if cmdDir <> '' then sei.lpDirectory := PChar(cmdDir);	291	if cmdDir <> '' then sei.lpDirectory := PChar(cmdDir);
292	sei.nShow := WindowMode;	292	sei.nShow := WindowMode;
293	if ShellExecuteEx(@sei) then Exit;	293	if ShellExecuteEx(@sei) then Exit;
294	{$IFNDEF PREFER_SHELLEXECUTEEX_MESSAGES}	294	{$IFNDEF PREFER_SHELLEXECUTEEX_MESSAGES}
295	if not CheckLastOSCall(false) then ExitCode := EXITCODE_RUN_FAILURE;	295	if not CheckLastOSCall(false) then ExitCode := EXITCODE_RUN_FAILURE;
296	{$ENDIF}	296	{$ENDIF}
297	end;	297	end;
298		298
299	function GetHTML(AUrl: string): string;	299	function GetHTML(AUrl: string): string;
300	// http://www.delphipraxis.net/post43515.html	300	// http://www.delphipraxis.net/post43515.html
301	// Modificated by ViaThinkSoft	301	// Modificated by ViaThinkSoft
302	var	302	var
303	databuffer : array[0..4095] of char;	303	databuffer : array[0..4095] of char;
304	ResStr : string;	304	ResStr : string;
305	hSession, hfile: hInternet;	305	hSession, hfile: hInternet;
306	dwindex,dwcodelen,dwread,dwNumber: cardinal;	306	dwindex,dwcodelen,dwread,dwNumber: cardinal;
307	dwcode : array[1..20] of char;	307	dwcode : array[1..20] of char;
308	res : pchar;	308	res : pchar;
309	Str : pchar;	309	Str : pchar;
310	begin	310	begin
311	ResStr := '';	311	ResStr := '';
312	if system.pos('http://',lowercase(AUrl)) = 0 then	312	if system.pos('http://',lowercase(AUrl)) = 0 then
313	begin	313	begin
314	AUrl:='http://'+AUrl;	314	AUrl:='http://'+AUrl;
315	end;	315	end;
316		316
317	// [ViaThinkSoft] Added	317	// [ViaThinkSoft] Added
318	Application.ProcessMessages;	318	Application.ProcessMessages;
319		319
320	hSession:=InternetOpen('InetURL:/1.0',	320	hSession:=InternetOpen('InetURL:/1.0',
321	INTERNET_OPEN_TYPE_PRECONFIG,	321	INTERNET_OPEN_TYPE_PRECONFIG,
322	nil,	322	nil,
323	nil,	323	nil,
324	0);	324	0);
325	if assigned(hsession) then	325	if assigned(hsession) then
326	begin	326	begin
327	// [ViaThinkSoft] Added	327	// [ViaThinkSoft] Added
328	Application.ProcessMessages;	328	Application.ProcessMessages;
329		329
330	hfile := InternetOpenUrl(hsession,	330	hfile := InternetOpenUrl(hsession,
331	pchar(AUrl),	331	pchar(AUrl),
332	nil,	332	nil,
333	0,	333	0,
334	INTERNET_FLAG_RELOAD,	334	INTERNET_FLAG_RELOAD,
335	0);	335	0);
336	dwIndex := 0;	336	dwIndex := 0;
337	dwCodeLen := 10;	337	dwCodeLen := 10;
338		338
339	// [ViaThinkSoft] Added	339	// [ViaThinkSoft] Added
340	Application.ProcessMessages;	340	Application.ProcessMessages;
341		341
342	HttpQueryInfo(hfile,	342	HttpQueryInfo(hfile,
343	HTTP_QUERY_STATUS_CODE,	343	HTTP_QUERY_STATUS_CODE,
344	@dwcode,	344	@dwcode,
345	dwcodeLen,	345	dwcodeLen,
346	dwIndex);	346	dwIndex);
347	res := pchar(@dwcode);	347	res := pchar(@dwcode);
348	dwNumber := sizeof(databuffer)-1;	348	dwNumber := sizeof(databuffer)-1;
349	if (res ='200') or (res ='302') then	349	if (res ='200') or (res ='302') then
350	begin	350	begin
351	while (InternetReadfile(hfile,	351	while (InternetReadfile(hfile,
352	@databuffer,	352	@databuffer,
353	dwNumber,	353	dwNumber,
354	DwRead)) do	354	DwRead)) do
355	begin	355	begin
356		356
357	// [ViaThinkSoft] Added	357	// [ViaThinkSoft] Added
358	Application.ProcessMessages;	358	Application.ProcessMessages;
359		359
360	if dwRead =0 then	360	if dwRead =0 then
361	break;	361	break;
362	databuffer[dwread]:=#0;	362	databuffer[dwread]:=#0;
363	Str := pchar(@databuffer);	363	Str := pchar(@databuffer);
364	resStr := resStr + Str;	364	resStr := resStr + Str;
365	end;	365	end;
366	end	366	end
367	else	367	else
368	ResStr := 'Status:'+res;	368	ResStr := 'Status:'+res;
369	if assigned(hfile) then	369	if assigned(hfile) then
370	InternetCloseHandle(hfile);	370	InternetCloseHandle(hfile);
371	end;	371	end;
372		372
373	// Hinzugefügt	373	// Hinzugefügt
374	Application.ProcessMessages;	374	Application.ProcessMessages;
375		375
376	InternetCloseHandle(hsession);	376	InternetCloseHandle(hsession);
377	Result := resStr;	377	Result := resStr;
378	end;	378	end;
379		379
380	procedure VTS_CheckUpdates(VTSID, CurVer: string);	380	procedure VTS_CheckUpdates(VTSID, CurVer: string);
381	resourcestring	381	resourcestring
382	(*	382	(*
383	LNG_DOWNLOAD_ERR = 'Ein Fehler ist aufgetreten. Wahrscheinlich ist keine Internetverbindung aufgebaut, oder der der ViaThinkSoft-Server temporär offline.';	383	LNG_DOWNLOAD_ERR = 'Ein Fehler ist aufgetreten. Wahrscheinlich ist keine Internetverbindung aufgebaut, oder der der ViaThinkSoft-Server temporär offline.';
384	LNG_NEW_VERSION = 'Eine neue Programmversion ist vorhanden. Möchten Sie diese jetzt herunterladen?';	384	LNG_NEW_VERSION = 'Eine neue Programmversion ist vorhanden. Möchten Sie diese jetzt herunterladen?';
385	LNG_NO_UPDATE = 'Es ist keine neue Programmversion vorhanden.';	385	LNG_NO_UPDATE = 'Es ist keine neue Programmversion vorhanden.';
386	*)	386	*)
387	LNG_DOWNLOAD_ERR = 'An error occurred while searching for updates. Please check your internet connection and firewall.';	387	LNG_DOWNLOAD_ERR = 'An error occurred while searching for updates. Please check your internet connection and firewall.';
388	LNG_NEW_VERSION = 'A new version is available. Do you want to download it now?';	388	LNG_NEW_VERSION = 'A new version is available. Do you want to download it now?';
389	LNG_NO_UPDATE = 'You already have the newest program version.';	389	LNG_NO_UPDATE = 'You already have the newest program version.';
390	var	390	var
391	status: string;	391	status: string;
392	begin	392	begin
393	status := GetHTML('http://www.viathinksoft.de/update/?id='+VTSID);	393	status := GetHTML('http://www.viathinksoft.de/update/?id='+VTSID);
394	if Copy(status, 0, 7) = 'Status:' then	394	if Copy(status, 0, 7) = 'Status:' then
395	begin	395	begin
396	MessageDlg(LNG_DOWNLOAD_ERR, mtError, [mbOK], 0);	396	MessageDlg(LNG_DOWNLOAD_ERR, mtError, [mbOK], 0);
397	end	397	end
398	else	398	else
399	begin	399	begin
400	if status <> CurVer then	400	if status <> CurVer then
401	begin	401	begin
402	if MessageDlg(LNG_NEW_VERSION, mtConfirmation, mbYesNoCancel, 0) = ID_YES then	402	if MessageDlg(LNG_NEW_VERSION, mtConfirmation, mbYesNoCancel, 0) = ID_YES then
403	begin	403	begin
404	shellexecute(application.handle, 'open', pchar('http://www.viathinksoft.de/update/?id=@'+VTSID), '', '', sw_normal);	404	shellexecute(application.handle, 'open', pchar('http://www.viathinksoft.de/update/?id=@'+VTSID), '', '', SW_Normal);
405	end;	405	end;
406	end	406	end
407	else	407	else
408	begin	408	begin
409	MessageDlg(LNG_NO_UPDATE, mtInformation, [mbOk], 0);	409	MessageDlg(LNG_NO_UPDATE, mtInformation, [mbOk], 0);
410	end;	410	end;
411	end;	411	end;
412	end;	412	end;
413		413
414	function CheckBoolParam(idx: integer; name: string): boolean;	414	function CheckBoolParam(idx: integer; name: string): boolean;
415	begin	415	begin
416	Result := ('/'+LowerCase(name) = LowerCase(ParamStr(idx))) or	416	Result := ('/'+LowerCase(name) = LowerCase(ParamStr(idx))) or
417	('-'+LowerCase(name) = LowerCase(ParamStr(idx)));	417	('-'+LowerCase(name) = LowerCase(ParamStr(idx)));
418	end;	418	end;
-		419
-		420	// function GetThreadErrorMode: DWORD; stdcall; external kernel32 name 'GetThreadErrorMode';
-		421	function UD2_GetThreadErrorMode: DWORD;
-		422	type
-		423	TFuncGetThreadErrorMode = function: DWORD; stdcall;
-		424	var
-		425	dllHandle: Cardinal;
-		426	fGetThreadErrorMode: TFuncGetThreadErrorMode;
-		427	begin
-		428	dllHandle := LoadLibrary(kernel32);
-		429	if dllHandle = 0 then
-		430	begin
-		431	result := 0;
-		432	Exit;
-		433	end;
-		434	try
-		435	@fGetThreadErrorMode := GetProcAddress(dllHandle, 'GetThreadErrorMode');
-		436	if not Assigned(fGetThreadErrorMode) then
-		437	begin
-		438	result := 0; // Windows Vista and prior
-		439	Exit;
-		440	end;
-		441	result := fGetThreadErrorMode();
-		442	finally
-		443	FreeLibrary(dllHandle);
-		444	end;
-		445	end;
-		446
-		447	// function SetThreadErrorMode(dwNewMode: DWORD; lpOldMode: LPDWORD): BOOL; stdcall; external kernel32 name 'SetThreadErrorMode';
-		448	function UD2_SetThreadErrorMode(dwNewMode: DWORD; lpOldMode: LPDWORD): BOOL;
-		449	type
-		450	TFuncSetThreadErrorMode = function(dwNewMode: DWORD; lpOldMode: LPDWORD): BOOL; stdcall;
-		451	var
-		452	dllHandle: Cardinal;
-		453	fSetThreadErrorMode: TFuncSetThreadErrorMode;
-		454	begin
-		455	dllHandle := LoadLibrary(kernel32);
-		456	if dllHandle = 0 then
-		457	begin
-		458	result := FALSE;
-		459	if Assigned(lpOldMode) then lpOldMode^ := UD2_GetThreadErrorMode;
-		460	Exit;
-		461	end;
-		462	try
-		463	@fSetThreadErrorMode := GetProcAddress(dllHandle, 'SetThreadErrorMode');
-		464	if not Assigned(fSetThreadErrorMode) then
-		465	begin
-		466	result := FALSE; // Windows Vista and prior
-		467	if Assigned(lpOldMode) then lpOldMode^ := UD2_GetThreadErrorMode;
-		468	Exit;
-		469	end;
-		470	result := fSetThreadErrorMode(dwNewMode, lpOldMode);
-		471	finally
-		472	FreeLibrary(dllHandle);
-		473	end;
-		474	end;
-		475
-		476	function IndexOf_CS(aStrings: TStrings; aToken: String): Integer;
-		477	// Source: http://www.delphipraxis.net/888928-post15.html
-		478	var
-		479	i : Integer;
-		480	begin
-		481	Result := -1;
-		482	for i := 0 to aStrings.Count do
-		483	if aStrings[i]=aToken then begin
-		484	Result := i;
-		485	Break;
-		486	end;
-		487	end;
419		488
420	end.	489	end.
421		490

Subversion Repositories userdetect2

userdetect2/trunk/UserDetect2/UD2_Utils.pas – Rev 81 → 82