Subversion Repositories userdetect2

Rev

Rev 95 | Show entire file | Regard whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 95 Rev 100
Line 45... Line 45...
45 
function GetFileVersion(const FileName: string=''): string;
 45 
function GetFileVersion(const FileName: string=''): string;
46 
 
 46 
 
47 
implementation
 47 
implementation
48 
 
 48 
 
49 
uses
 49 
uses
50 
  idhttp, Forms;
 50 
  wininet, Forms;
51 
 
 51 
 
52 
function SplitString(const aSeparator, aString: string; aMax: Integer = 0): TArrayOfString;
 52 
function SplitString(const aSeparator, aString: string; aMax: Integer = 0): TArrayOfString;
53 
// http://stackoverflow.com/a/2626991/3544341
 53 
// https://stackoverflow.com/a/2626991/3544341
54 
var
 54 
var
55 
  i, strt, cnt: Integer;
 55 
  i, strt, cnt: Integer;
56 
  sepLen: Integer;
 56 
  sepLen: Integer;
57 
 
 57 
 
58 
  procedure AddString(aEnd: Integer = -1);
 58 
  procedure AddString(aEnd: Integer = -1);
Line 137... Line 137...
137 
  result := ChangeFileExt(result, '');
 137 
  result := ChangeFileExt(result, '');
138 
  result := UpperCase(result);
 138 
  result := UpperCase(result);
139 
end;
 139 
end;
140 
 
 140 
 
141 
function ExpandEnvStr(const szInput: string): string;
 141 
function ExpandEnvStr(const szInput: string): string;
142 
// http://stackoverflow.com/a/2833147/3544341
 142 
// https://stackoverflow.com/a/2833147/3544341
143 
const
 143 
const
144 
  MAXSIZE = 32768;
 144 
  MAXSIZE = 32768;
145 
begin
 145 
begin
146 
  SetLength(Result, MAXSIZE);
 146 
  SetLength(Result, MAXSIZE);
147 
  SetLength(Result, ExpandEnvironmentStrings(pchar(szInput),
 147 
  SetLength(Result, ExpandEnvironmentStrings(pchar(szInput),
Line 194... Line 194...
194 
    result.IconIndex := StrToInt(Copy(IconString, p+1, Length(IconString)-p));
 194 
    result.IconIndex := StrToInt(Copy(IconString, p+1, Length(IconString)-p));
195 
  end;
 195 
  end;
196 
end;
 196 
end;
197 
 
 197 
 
198 
procedure UD2_RunCMD(cmd: TUD2Command);
 198 
procedure UD2_RunCMD(cmd: TUD2Command);
199 
// Discussion: http://stackoverflow.com/questions/32802679/acceptable-replacement-for-winexec/32804669#32804669
 199 
// Discussion: https://stackoverflow.com/questions/32802679/acceptable-replacement-for-winexec/32804669#32804669
200 
// Version 1: http://pastebin.com/xQjDmyVe
 200 
// Version 1: https://pastebin.com/xQjDmyVe
201 
// --> CreateProcess + ShellExecuteEx
 201 
// --> CreateProcess + ShellExecuteEx
202 
// --> Problem: Run-In-Same-Directory functionality is not possible
 202 
// --> Problem: Run-In-Same-Directory functionality is not possible
203 
//              (requires manual command and argument separation)
 203 
//              (requires manual command and argument separation)
204 
// Version 2: http://pastebin.com/YpUmF5rd
 204 
// Version 2: https://pastebin.com/YpUmF5rd
205 
// --> Splits command and arguments manually, and uses ShellExecute
 205 
// --> Splits command and arguments manually, and uses ShellExecute
206 
// --> Problem: error handling wrong
 206 
// --> Problem: error handling wrong
207 
// --> Problem: Run-In-Same-Directory functionality is not implemented
 207 
// --> Problem: Run-In-Same-Directory functionality is not implemented
208 
// Current version:
 208 
// Current version:
209 
// --> Splits command and arguments manually, and uses ShellExecute
 209 
// --> Splits command and arguments manually, and uses ShellExecute
Line 288... Line 288...
288 
  {$IFNDEF PREFER_SHELLEXECUTEEX_MESSAGES}
 288 
  {$IFNDEF PREFER_SHELLEXECUTEEX_MESSAGES}
289 
  if not CheckLastOSCall(false) then ExitCode := EXITCODE_RUN_FAILURE;
 289 
  if not CheckLastOSCall(false) then ExitCode := EXITCODE_RUN_FAILURE;
290 
  {$ENDIF}
 290 
  {$ENDIF}
291 
end;
 291 
end;
292 
 
 292 
 
- 
 
 293 
(*
293 
function GetHTML(const url: string): string;
 294 
function GetHTML(const url: string): string;
294 
var
 295 
var
295 
  idhttp :Tidhttp;
 296 
  idhttp :Tidhttp;
296 
begin
 297 
begin
297 
  idhttp := Tidhttp.Create(nil);
 298 
  idhttp := Tidhttp.Create(nil);
Line 299... Line 300...
299 
    result := idhttp.Get(url);
 300 
    result := idhttp.Get(url);
300 
  finally
 301 
  finally
301 
    idhttp.Free;
 302 
    idhttp.Free;
302 
  end;
 303 
  end;
303 
end;
 304 
end;
- 
 
 305 
*)
- 
 
 306 
// https://www.delphipraxis.net/post43515.html , fixed , works for Delphi 12 Athens
- 
 
 307 
function GetHTML(AUrl: string): RawByteString;
- 
 
 308 
var
- 
 
 309 
  databuffer : array[0..4095] of ansichar; // SIC! ansichar!
- 
 
 310 
  ResStr : ansistring; // SIC! ansistring
- 
 
 311 
  hSession, hfile: hInternet;
- 
 
 312 
  dwindex,dwcodelen,dwread,dwNumber: cardinal;
- 
 
 313 
  dwcode : array[1..20] of char;
- 
 
 314 
  res    : pchar;
- 
 
 315 
  Str    : pansichar; // SIC! pansichar
- 
 
 316 
begin
- 
 
 317 
  ResStr:='';
- 
 
 318 
  if (system.pos('http://',lowercase(AUrl))=0) and
- 
 
 319 
     (system.pos('https://',lowercase(AUrl))=0) then
- 
 
 320 
     AUrl:='http://'+AUrl;
- 
 
 321 
 
- 
 
 322 
  // Hinzugefügt
- 
 
 323 
  if Assigned(Application) then Application.ProcessMessages;
- 
 
 324 
 
- 
 
 325 
  hSession:=InternetOpen('InetURL:/1.0',
- 
 
 326 
                         INTERNET_OPEN_TYPE_PRECONFIG,
- 
 
 327 
                         nil,
- 
 
 328 
                         nil,
- 
 
 329 
                         0);
- 
 
 330 
  if assigned(hsession) then
- 
 
 331 
  begin
- 
 
 332 
    // Hinzugefügt
- 
 
 333 
    if Assigned(Application) then application.ProcessMessages;
- 
 
 334 
 
- 
 
 335 
    hfile:=InternetOpenUrl(
- 
 
 336 
           hsession,
- 
 
 337 
           pchar(AUrl),
- 
 
 338 
           nil,
- 
 
 339 
           0,
- 
 
 340 
           INTERNET_FLAG_RELOAD,
- 
 
 341 
           0);
- 
 
 342 
    dwIndex  := 0;
- 
 
 343 
    dwCodeLen := 10;
- 
 
 344 
 
- 
 
 345 
    // Hinzugefügt
- 
 
 346 
    if Assigned(Application) then application.ProcessMessages;
- 
 
 347 
 
- 
 
 348 
    HttpQueryInfo(hfile,
- 
 
 349 
                  HTTP_QUERY_STATUS_CODE,
- 
 
 350 
                  @dwcode,
- 
 
 351 
                  dwcodeLen,
- 
 
 352 
                  dwIndex);
- 
 
 353 
    res := pchar(@dwcode);
- 
 
 354 
    dwNumber := sizeof(databuffer)-1;
- 
 
 355 
    if (res ='200') or (res = '302') then
- 
 
 356 
    begin
- 
 
 357 
      while (InternetReadfile(hfile,
- 
 
 358 
                              @databuffer,
- 
 
 359 
                              dwNumber,
- 
 
 360 
                              DwRead)) do
- 
 
 361 
      begin
- 
 
 362 
 
- 
 
 363 
        // Hinzugefügt
- 
 
 364 
        if Assigned(Application) then application.ProcessMessages;
- 
 
 365 
 
- 
 
 366 
        if dwRead =0 then
- 
 
 367 
          break;
- 
 
 368 
        databuffer[dwread]:=#0;
- 
 
 369 
        Str := pansichar(@databuffer);
- 
 
 370 
        resStr := resStr + Str;
- 
 
 371 
      end;
- 
 
 372 
    end
- 
 
 373 
    else
- 
 
 374 
      ResStr := 'Status:'+AnsiString(res);
- 
 
 375 
    if assigned(hfile) then
- 
 
 376 
      InternetCloseHandle(hfile);
- 
 
 377 
  end;
- 
 
 378 
 
- 
 
 379 
  // Hinzugefügt
- 
 
 380 
  if Assigned(Application) then application.ProcessMessages;
- 
 
 381 
 
- 
 
 382 
  InternetCloseHandle(hsession);
- 
 
 383 
  Result := resStr;
- 
 
 384 
end;
304 
 
 385 
 
305 
procedure VTS_CheckUpdates(VTSID, CurVer: string);
 386 
procedure VTS_CheckUpdates(VTSID, CurVer: string);
306 
resourcestring
 387 
resourcestring
307 
  (*
 388 
  (*
308 
  LNG_DOWNLOAD_ERR = 'Ein Fehler ist aufgetreten. Wahrscheinlich ist keine Internetverbindung aufgebaut, oder der der ViaThinkSoft-Server temporär offline.';
 389 
  LNG_DOWNLOAD_ERR = 'Ein Fehler ist aufgetreten. Wahrscheinlich ist keine Internetverbindung aufgebaut, oder der der ViaThinkSoft-Server temporär offline.';
Line 311... Line 392...
311 
  *)
 392 
  *)
312 
  LNG_DOWNLOAD_ERR = 'An error occurred while searching for updates. Please check your internet connection and firewall.';
 393 
  LNG_DOWNLOAD_ERR = 'An error occurred while searching for updates. Please check your internet connection and firewall.';
313 
  LNG_NEW_VERSION = 'A new version is available. Do you want to download it now?';
 394 
  LNG_NEW_VERSION = 'A new version is available. Do you want to download it now?';
314 
  LNG_NO_UPDATE = 'You already have the newest program version.';
 395 
  LNG_NO_UPDATE = 'You already have the newest program version.';
315 
var
 396 
var
316 
  status: string;
 397 
  status: RawByteString;
317 
begin
 398 
begin
318 
  status := GetHTML('http://www.viathinksoft.de/update/?id='+VTSID);
 399 
  status := GetHTML('https://www.viathinksoft.de/update/?id='+VTSID);
319 
  if Copy(status, 0, 7) = 'Status:' then
 400 
  if Copy(status, 0, 7) = 'Status:' then
320 
  begin
 401 
  begin
321 
    MessageDlg(LNG_DOWNLOAD_ERR, mtError, [mbOK], 0);
 402 
    MessageDlg(LNG_DOWNLOAD_ERR, mtError, [mbOK], 0);
322 
  end
 403 
  end
323 
  else
 404 
  else
324 
  begin
 405 
  begin
325 
    if status <> CurVer then
 406 
    if string(status) <> CurVer then
326 
    begin
 407 
    begin
327 
      if MessageDlg(LNG_NEW_VERSION, mtConfirmation, mbYesNoCancel, 0) = ID_YES then
 408 
      if MessageDlg(LNG_NEW_VERSION, mtConfirmation, mbYesNoCancel, 0) = ID_YES then
328 
      begin
 409 
      begin
329 
        shellexecute(application.handle, 'open', pchar('http://www.viathinksoft.de/update/?id=@'+VTSID), '', '', SW_Normal);
 410 
        shellexecute(application.handle, 'open', pchar('https://www.viathinksoft.de/update/?id=@'+VTSID), '', '', SW_Normal);
330 
      end;
 411 
      end;
331 
    end
 412 
    end
332 
    else
 413 
    else
333 
    begin
 414 
    begin
334 
      MessageDlg(LNG_NO_UPDATE, mtInformation, [mbOk], 0);
 415 
      MessageDlg(LNG_NO_UPDATE, mtInformation, [mbOk], 0);