Patcher

[Horst0815]

Delphi-Quellcode:

unit uUpdate;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, UrlMon, ActiveX, StdCtrls, ShellAPI, ComCtrls, WinINet;

type
  TfrmUpdate = class(TForm)
    btnUpdateCheck: TButton;
    MemoInfo: TMemo;
    Fortschritt: TProgressBar;
    procedure btnUpdateCheckClick(Sender: TObject);
    Function GetHTML(AUrl: string): string;
  private
    { Private-Deklarationen }
  public
    { Pu
      blic-Deklarationen }
  end;

type
  cDownloadStatusCallback = class(TObject, IUnknown, IBindStatusCallback)
  private
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    function OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult; stdcall;
    function GetPriority(out nPriority): HResult; stdcall;
    function OnLowResource(reserved: DWORD): HResult; stdcall;
    function OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
      szStatusText: LPCWSTR): HResult; stdcall;
    function OnStopBinding(HResult: HResult; szError: LPCWSTR)
      : HResult; stdcall;
    function GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo)
      : HResult; stdcall;
    function OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD;
      formatetc: PFormatEtc; stgmed: PStgMedium): HResult; stdcall;
    function OnObjectAvailable(const IID: TGUID; punk: IUnknown)
      : HResult; stdcall;
  end;

var
  frmUpdate: TfrmUpdate;
  actual_version, last_version, waiting: string;
  cDownStatus: cDownloadStatusCallback;
  Datei, Ziel: PChar;
  rounds: Integer;
  usercancel: Boolean = False;

implementation

{$R *.dfm}

procedure TfrmUpdate.btnUpdateCheckClick(Sender: TObject);
begin
  if btnUpdateCheck.Tag = 1 then
  begin
    waiting := '';
    rounds := 0;
    sleep(10);
    MemoInfo.clear;
    application.ProcessMessages;
    cDownStatus := cDownloadStatusCallback.Create;
    try
      Datei := 'http://www.DeineHP.de/Setup.exe';
      Ziel := 'Setup.exe';
      UrlDownloadToFile(nil, Datei, Ziel, 0, cDownStatus);
      if MessageBox(0, 'DOWNLOAD COMPLETE, RESTART', 'Info',
        MB_OKCANCEL) = IDOK then
      Begin
        ShellExecute(application.Handle, 'open', PChar('Setup.exe'), nil,
          nil, SW_ShowNormal);
        application.terminate;
      End
      else
      begin
        btnUpdateCheck.Caption := 'Please install Update';
        btnUpdateCheck.Enabled := False;
        Exit;
      end;
    except
      showmessage('Download aborted!');
    end;
  end;
  if btnUpdateCheck.Tag = 0 then
  begin
    MemoInfo.clear;
    last_version := GetHTML('http://www.DeineHP.de/version.txt');
    if actual_version <> last_version then
    begin
      MemoInfo.lines.add('NEW UPDATE AVAILABLE! ' + last_version);
      MemoInfo.lines.add
        ('PRESS "DOWNLOAD NEW UPDATE NOW!" Button to get newest update!');
      btnUpdateCheck.Tag := 1;
      btnUpdateCheck.Caption := 'DOWNLOAD NEW UPDATE NOW!';
      btnUpdateCheck.font.size := 18;
      btnUpdateCheck.font.style := [fsBold];
    end
    else
    begin
      MemoInfo.lines.add('YOU USE THE LATEST AVAILABLE VERSION');
      MemoInfo.lines.add(GetHTML('http://www.DeineHP.de/news.txt'));
      MemoInfo.Perform(WM_VSCROLL, SB_TOP, 0);
    end;
  end;
end;

function cDownloadStatusCallback._AddRef: Integer;
begin
  Result := 0;
end;

function cDownloadStatusCallback._Release: Integer;
begin
  Result := 0;
end;

function cDownloadStatusCallback.QueryInterface(const IID: TGUID;
  out Obj): HResult;
begin
  if (GetInterface(IID, Obj)) then
  begin
    Result := 0
  end
  else
  begin
    Result := E_NOINTERFACE;
  end;
end;

function cDownloadStatusCallback.OnStartBinding(dwReserved: DWORD;
  pib: IBinding): HResult;
begin
  Result := S_OK;
end;

function cDownloadStatusCallback.GetPriority(out nPriority): HResult;
begin
  Result := S_OK;
end;

function cDownloadStatusCallback.OnLowResource(reserved: DWORD): HResult;
begin
  Result := S_OK;
end;

function cDownloadStatusCallback.OnStopBinding(HResult: HResult;
  szError: LPCWSTR): HResult; stdcall;
begin
  Result := S_OK;
end;

function cDownloadStatusCallback.GetBindInfo(out grfBINDF: DWORD;
  var bindinfo: TBindInfo): HResult; stdcall;
begin
  Result := S_OK;
end;

function cDownloadStatusCallback.OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD;
  formatetc: PFormatEtc; stgmed: PStgMedium): HResult;
begin
  Result := S_OK;
end;

function cDownloadStatusCallback.OnObjectAvailable(const IID: TGUID;
  punk: IUnknown): HResult; stdcall;
begin
  Result := S_OK;
end;

function cDownloadStatusCallback.OnProgress(ulProgress, ulProgressMax,
  ulStatusCode: ULONG; szStatusText: LPCWSTR): HResult;
begin

  case ulStatusCode of
    BINDSTATUS_FINDINGRESOURCE:
      begin
        frmUpdate.MemoInfo.lines.add('File found on server.');
        if (usercancel) then
        begin
          Result := E_ABORT;
          Exit;
        end;
      end;
    BINDSTATUS_CONNECTING:
      begin
        frmUpdate.MemoInfo.lines.add('Connecting to Server..');
        if (usercancel) then
        begin
          Result := E_ABORT;
          Exit;
        end;
      end;
    BINDSTATUS_BEGINDOWNLOADDATA:
      begin
        frmUpdate.Fortschritt.Position := 0;
        frmUpdate.MemoInfo.lines.add('Start Downloading...');
        if (usercancel) then
        begin
          Result := E_ABORT;
          Exit;
        end;
      end;
    BINDSTATUS_DOWNLOADINGDATA:
      begin
        frmUpdate.Fortschritt.Position :=
          MulDiv(ulProgress, 100, ulProgressMax);
        // Form1.memo2.lines.add('Downloading.. PLEASE WAIT');

        rounds := rounds + 1;
        // if rounds = 50 then
        // begin
        // rounds := 0;
        // frmUpdate.MemoInfo.lines.Delete(frmUpdate.MemoInfo.lines.Count - 1);
        // waiting := waiting + '.';
        // frmUpdate.MemoInfo.lines.add('Downloading new Update' + waiting);
        // end;

        if (usercancel) then
        begin
          Result := E_ABORT;
          Exit;
        end;
      end;
    BINDSTATUS_ENDDOWNLOADDATA:
      begin
        frmUpdate.MemoInfo.lines.add('DOWNLOAD FINISHED!');
      end;
  end;
  Result := S_OK;
end;

Function TfrmUpdate.GetHTML(AUrl: string): string;
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 := '';
  Result := '';
  if pos('http://', lowercase(AUrl)) = 0 then
    AUrl := 'http://' + AUrl;
  hSession := InternetOpen('InetURL:/1.0', INTERNET_OPEN_TYPE_PRECONFIG,
    nil, nil, 0);
  If assigned(hSession) Then
    Try
      hfile := InternetOpenUrl(hSession, PChar(AUrl), nil, 0,
        INTERNET_FLAG_RELOAD, 0);
      if assigned(hfile) then
        Try
          dwindex := 0;
          dwcodelen := 10;
          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)) AND
              (dwread <> 0) do
            begin
              databuffer[dwread] := #0;
              Str := PChar(@databuffer);
              ResStr := ResStr + Str;
            end;
          end
          else
            ResStr := 'Status:' + res;
        Finally
          InternetCloseHandle(hfile);
        End;
    Finally
      InternetCloseHandle(hSession);
    End;
  Result := ResStr;
end;

end.