Rev 70 | Go to most recent revision | Details | Last modification | View Log | RSS feed
Rev | Author | Line No. | Line |
---|---|---|---|
68 | daniel-mar | 1 | unit UD2_Utils; |
2 | |||
3 | interface |
||
4 | |||
5 | {$IF CompilerVersion >= 25.0} |
||
6 | {$LEGACYIFEND ON} |
||
7 | {$IFEND} |
||
8 | |||
9 | uses |
||
10 | Windows, SysUtils, Dialogs, ShellAPI; |
||
11 | |||
12 | type |
||
13 | TArrayOfString = array of String; |
||
14 | |||
15 | TIconFileIdx = record |
||
16 | FileName: string; |
||
17 | IconIndex: integer; |
||
18 | end; |
||
19 | |||
20 | const |
||
21 | // Prefixes for UD2_RunCmd() |
||
22 | UD2_RUN_IN_OWN_DIRECTORY_PREFIX = '$RIOD$'; |
||
23 | |||
24 | function SplitString(const aSeparator, aString: String; aMax: Integer = 0): TArrayOfString; |
||
25 | function BetterInterpreteBool(str: String): boolean; |
||
26 | function GetOwnCmdName: string; |
||
27 | function ExpandEnvStr(const szInput: string): string; |
||
28 | procedure UD2_RunCMD(cmdLine: string; WindowMode: integer); |
||
29 | function SplitIconString(IconString: string): TIconFileIdx; |
||
30 | // function GetHTML(AUrl: string): string; |
||
31 | procedure VTS_CheckUpdates(VTSID, CurVer: string); |
||
32 | |||
33 | implementation |
||
34 | |||
35 | uses |
||
36 | WinInet, Forms; |
||
37 | |||
38 | function SplitString(const aSeparator, aString: String; aMax: Integer = 0): TArrayOfString; |
||
39 | // http://stackoverflow.com/a/2626991/3544341 |
||
40 | var |
||
41 | i, strt, cnt: Integer; |
||
42 | sepLen: Integer; |
||
43 | |||
44 | procedure AddString(aEnd: Integer = -1); |
||
45 | var |
||
46 | endPos: Integer; |
||
47 | begin |
||
48 | if (aEnd = -1) then |
||
49 | endPos := i |
||
50 | else |
||
51 | endPos := aEnd + 1; |
||
52 | |||
53 | if (strt < endPos) then |
||
54 | result[cnt] := Copy(aString, strt, endPos - strt) |
||
55 | else |
||
56 | result[cnt] := ''; |
||
57 | |||
58 | Inc(cnt); |
||
59 | end; |
||
60 | |||
61 | begin |
||
62 | if (aString = '') or (aMax < 0) then |
||
63 | begin |
||
64 | SetLength(result, 0); |
||
65 | EXIT; |
||
66 | end; |
||
67 | |||
68 | if (aSeparator = '') then |
||
69 | begin |
||
70 | SetLength(result, 1); |
||
71 | result[0] := aString; |
||
72 | EXIT; |
||
73 | end; |
||
74 | |||
75 | sepLen := Length(aSeparator); |
||
76 | SetLength(result, (Length(aString) div sepLen) + 1); |
||
77 | |||
78 | i := 1; |
||
79 | strt := i; |
||
80 | cnt := 0; |
||
81 | while (i <= (Length(aString)- sepLen + 1)) do |
||
82 | begin |
||
83 | if (aString[i] = aSeparator[1]) then |
||
84 | if (Copy(aString, i, sepLen) = aSeparator) then |
||
85 | begin |
||
86 | AddString; |
||
87 | |||
88 | if (cnt = aMax) then |
||
89 | begin |
||
90 | SetLength(result, cnt); |
||
91 | EXIT; |
||
92 | end; |
||
93 | |||
94 | Inc(i, sepLen - 1); |
||
95 | strt := i + 1; |
||
96 | end; |
||
97 | |||
98 | Inc(i); |
||
99 | end; |
||
100 | |||
101 | AddString(Length(aString)); |
||
102 | |||
103 | SetLength(result, cnt); |
||
104 | end; |
||
105 | |||
106 | function BetterInterpreteBool(str: String): boolean; |
||
107 | resourcestring |
||
108 | LNG_CANNOT_INTERPRETE_BOOL = 'Cannot determinate the boolean value of "%s"'; |
||
109 | begin |
||
110 | str := LowerCase(str); |
||
111 | if (str = 'yes') or (str = 'true') or (str = '1') then |
||
112 | result := true |
||
113 | else if (str = 'no') or (str = 'false') or (str = '0') then |
||
114 | result := false |
||
115 | else |
||
116 | raise EConvertError.CreateFmt(LNG_CANNOT_INTERPRETE_BOOL, [str]); |
||
117 | end; |
||
118 | |||
119 | function GetOwnCmdName: string; |
||
120 | begin |
||
121 | result := ParamStr(0); |
||
122 | result := ExtractFileName(result); |
||
123 | result := ChangeFileExt(result, ''); |
||
124 | result := UpperCase(result); |
||
125 | end; |
||
126 | |||
127 | function ExpandEnvStr(const szInput: string): string; |
||
128 | // http://stackoverflow.com/a/2833147/3544341 |
||
129 | const |
||
130 | MAXSIZE = 32768; |
||
131 | begin |
||
132 | SetLength(Result, MAXSIZE); |
||
133 | SetLength(Result, ExpandEnvironmentStrings(pchar(szInput), |
||
134 | @Result[1],length(Result))); |
||
135 | end; |
||
136 | |||
137 | procedure CheckLastOSCall(AThrowException: boolean); |
||
138 | resourcestring |
||
139 | LNG_UNKNOWN_ERROR = 'Operating system error %d'; |
||
140 | var |
||
141 | LastError: Cardinal; |
||
142 | sError: string; |
||
143 | begin |
||
144 | LastError := GetLastError; |
||
145 | if LastError <> 0 then |
||
146 | begin |
||
147 | if AThrowException then |
||
148 | begin |
||
149 | RaiseLastOSError; |
||
150 | end |
||
151 | else |
||
152 | begin |
||
153 | sError := SysErrorMessage(LastError); |
||
154 | |||
155 | // Some errors have no error message, e.g. error 193 (BAD_EXE_FORMAT) in the German version of Windows 10 |
||
156 | if sError = '' then sError := Format(LNG_UNKNOWN_ERROR, [LastError]); |
||
157 | |||
158 | MessageDlg(sError, mtError, [mbOK], 0); |
||
159 | end; |
||
160 | end; |
||
161 | end; |
||
162 | |||
163 | function SplitIconString(IconString: string): TIconFileIdx; |
||
164 | var |
||
165 | p: integer; |
||
166 | begin |
||
167 | p := Pos(',', IconString); |
||
168 | |||
169 | if p = 0 then |
||
170 | begin |
||
171 | result.FileName := IconString; |
||
172 | result.IconIndex := 0; |
||
173 | end |
||
174 | else |
||
175 | begin |
||
176 | result.FileName := ExpandEnvStr(copy(IconString, 0, p-1)); |
||
177 | result.IconIndex := StrToInt(Copy(IconString, p+1, Length(IconString)-p)); |
||
178 | end; |
||
179 | end; |
||
180 | |||
181 | procedure UD2_RunCMD(cmdLine: string; WindowMode: integer); |
||
182 | // Discussion: http://stackoverflow.com/questions/32802679/acceptable-replacement-for-winexec/32804669#32804669 |
||
183 | // Version 1: http://pastebin.com/xQjDmyVe |
||
184 | // --> CreateProcess + ShellExecuteEx |
||
185 | // --> Problem: Run-In-Same-Directory functionality is not possible |
||
186 | // (requires manual command and argument separation) |
||
187 | // Version 2: http://pastebin.com/YpUmF5rd |
||
188 | // --> Splits command and arguments manually, and uses ShellExecute |
||
189 | // --> Problem: error handling wrong |
||
190 | // --> Problem: Run-In-Same-Directory functionality is not implemented |
||
191 | // Current version: |
||
192 | // --> Splits command and arguments manually, and uses ShellExecute |
||
193 | // --> Run-In-Same-Directory functionality is implemented |
||
194 | resourcestring |
||
195 | LNG_INVALID_SYNTAX = 'The command line has an invalid syntax'; |
||
196 | var |
||
197 | cmdFile, cmdArgs, cmdDir: string; |
||
198 | p: integer; |
||
199 | sei: TShellExecuteInfo; |
||
200 | begin |
||
201 | // We need a function which does following: |
||
202 | // 1. Replace the Environment strings, e.g. %SystemRoot% |
||
203 | // 2. Runs EXE files with parameters (e.g. "cmd.exe /?") |
||
204 | // 3. Runs EXE files without path (e.g. "calc.exe") |
||
205 | // 4. Runs EXE files without extension (e.g. "calc") |
||
206 | // 5. Runs non-EXE files (e.g. "Letter.doc") |
||
207 | // 6. Commands with white spaces (e.g. "C:\Program Files\xyz.exe") must be enclosed in quotes. |
||
208 | |||
209 | cmdLine := ExpandEnvStr(cmdLine); |
||
210 | |||
211 | // Split command line from argument list |
||
212 | if Copy(cmdLine, 1, 1) = '"' then |
||
213 | begin |
||
214 | cmdLine := Copy(cmdLine, 2, Length(cmdLine)-1); |
||
215 | p := Pos('"', cmdLine); |
||
216 | if p = 0 then |
||
217 | begin |
||
218 | // No matching quotes |
||
219 | // CreateProcess() handles the whole command line as single file name ("abc -> "abc") |
||
220 | // ShellExecuteEx() does not accept the command line |
||
221 | MessageDlg(LNG_INVALID_SYNTAX, mtError, [mbOK], 0); |
||
222 | Exit; |
||
223 | end; |
||
224 | cmdFile := Copy(cmdLine, 1, p-1); |
||
225 | cmdArgs := Copy(cmdLine, p+2, Length(cmdLine)-p-1); |
||
226 | end |
||
227 | else |
||
228 | begin |
||
229 | p := Pos(' ', cmdLine); |
||
230 | if p = 0 then |
||
231 | begin |
||
232 | cmdFile := cmdLine; |
||
233 | cmdArgs := ''; |
||
234 | end |
||
235 | else |
||
236 | begin |
||
237 | cmdFile := Copy(cmdLine, 1, p-1); |
||
238 | cmdArgs := Copy(cmdLine, p+1, Length(cmdLine)-p); |
||
239 | end; |
||
240 | end; |
||
241 | |||
242 | if Copy(cmdLine, 1, Length(UD2_RUN_IN_OWN_DIRECTORY_PREFIX)) = UD2_RUN_IN_OWN_DIRECTORY_PREFIX then |
||
243 | begin |
||
244 | cmdLine := Copy(cmdLine, 1+Length(UD2_RUN_IN_OWN_DIRECTORY_PREFIX), Length(cmdLine)-Length(UD2_RUN_IN_OWN_DIRECTORY_PREFIX)); |
||
245 | |||
246 | cmdFile := ExtractFileName(cmdLine); |
||
247 | cmdDir := ExtractFilePath(cmdLine); |
||
248 | end |
||
249 | else |
||
250 | begin |
||
251 | cmdFile := cmdLine; |
||
252 | cmdDir := ''; |
||
253 | end; |
||
254 | |||
255 | ZeroMemory(@sei, SizeOf(sei)); |
||
256 | sei.cbSize := SizeOf(sei); |
||
257 | sei.lpFile := PChar(cmdFile); |
||
258 | if cmdArgs <> '' then sei.lpParameters := PChar(cmdArgs); |
||
259 | if cmdDir <> '' then sei.lpDirectory := PChar(cmdDir); |
||
260 | sei.nShow := WindowMode; |
||
261 | if ShellExecuteEx(@sei) then Exit; |
||
262 | CheckLastOSCall(false); |
||
263 | end; |
||
264 | |||
265 | function GetHTML(AUrl: string): string; |
||
266 | // http://www.delphipraxis.net/post43515.html |
||
267 | var |
||
268 | databuffer : array[0..4095] of char; |
||
269 | ResStr : string; |
||
270 | hSession, hfile: hInternet; |
||
271 | dwindex,dwcodelen,dwread,dwNumber: cardinal; |
||
272 | dwcode : array[1..20] of char; |
||
273 | res : pchar; |
||
274 | Str : pchar; |
||
275 | begin |
||
276 | ResStr:=''; |
||
277 | if system.pos('http://',lowercase(AUrl))=0 then |
||
278 | AUrl:='http://'+AUrl; |
||
279 | |||
280 | // Hinzugefügt |
||
281 | Application.ProcessMessages; |
||
282 | |||
283 | hSession:=InternetOpen('InetURL:/1.0', |
||
284 | INTERNET_OPEN_TYPE_PRECONFIG, |
||
285 | nil, |
||
286 | nil, |
||
287 | 0); |
||
288 | if assigned(hsession) then |
||
289 | begin |
||
290 | // Hinzugefügt |
||
291 | application.ProcessMessages; |
||
292 | |||
293 | hfile:=InternetOpenUrl( |
||
294 | hsession, |
||
295 | pchar(AUrl), |
||
296 | nil, |
||
297 | 0, |
||
298 | INTERNET_FLAG_RELOAD, |
||
299 | 0); |
||
300 | dwIndex := 0; |
||
301 | dwCodeLen := 10; |
||
302 | |||
303 | // Hinzugefügt |
||
304 | application.ProcessMessages; |
||
305 | |||
306 | HttpQueryInfo(hfile, |
||
307 | HTTP_QUERY_STATUS_CODE, |
||
308 | @dwcode, |
||
309 | dwcodeLen, |
||
310 | dwIndex); |
||
311 | res := pchar(@dwcode); |
||
312 | dwNumber := sizeof(databuffer)-1; |
||
313 | if (res ='200') or (res ='302') then |
||
314 | begin |
||
315 | while (InternetReadfile(hfile, |
||
316 | @databuffer, |
||
317 | dwNumber, |
||
318 | DwRead)) do |
||
319 | begin |
||
320 | |||
321 | // Hinzugefügt |
||
322 | application.ProcessMessages; |
||
323 | |||
324 | if dwRead =0 then |
||
325 | break; |
||
326 | databuffer[dwread]:=#0; |
||
327 | Str := pchar(@databuffer); |
||
328 | resStr := resStr + Str; |
||
329 | end; |
||
330 | end |
||
331 | else |
||
332 | ResStr := 'Status:'+res; |
||
333 | if assigned(hfile) then |
||
334 | InternetCloseHandle(hfile); |
||
335 | end; |
||
336 | |||
337 | // Hinzugefügt |
||
338 | Application.ProcessMessages; |
||
339 | |||
340 | InternetCloseHandle(hsession); |
||
341 | Result := resStr; |
||
342 | end; |
||
343 | |||
344 | procedure VTS_CheckUpdates(VTSID, CurVer: string); |
||
345 | resourcestring |
||
346 | (* |
||
347 | LNG_DOWNLOAD_ERR = 'Ein Fehler ist aufgetreten. Wahrscheinlich ist keine Internetverbindung aufgebaut, oder der der ViaThinkSoft-Server temporär offline.'; |
||
348 | LNG_NEW_VERSION = 'Eine neue Programmversion ist vorhanden. Möchten Sie diese jetzt herunterladen?'; |
||
349 | LNG_NO_UPDATE = 'Es ist keine neue Programmversion vorhanden.'; |
||
350 | *) |
||
351 | LNG_DOWNLOAD_ERR = 'An error occurred while searching for updates. Please check your internet connection and firewall.'; |
||
352 | LNG_NEW_VERSION = 'A new version is available. Do you want to download it now?'; |
||
353 | LNG_NO_UPDATE = 'You already have the newest program version.'; |
||
354 | var |
||
355 | temp: string; |
||
356 | begin |
||
357 | temp := GetHTML('http://www.viathinksoft.de/update/?id='+VTSID); |
||
358 | if Copy(temp, 0, 7) = 'Status:' then |
||
359 | begin |
||
360 | MessageDlg(LNG_DOWNLOAD_ERR, mtError, [mbOK], 0); |
||
361 | end |
||
362 | else |
||
363 | begin |
||
364 | if GetHTML('http://www.viathinksoft.de/update/?id='+VTSID) <> CurVer then |
||
365 | begin |
||
366 | if MessageDlg(LNG_NEW_VERSION, mtConfirmation, mbYesNoCancel, 0) = ID_YES then |
||
367 | begin |
||
368 | shellexecute(application.handle, 'open', pchar('http://www.viathinksoft.de/update/?id=@spacemission'), '', '', sw_normal); |
||
369 | end; |
||
370 | end |
||
371 | else |
||
372 | begin |
||
373 | MessageDlg(LNG_NO_UPDATE, mtInformation, [mbOk], 0); |
||
374 | end; |
||
375 | end; |
||
376 | end; |
||
377 | |||
378 | end. |