unit1.pas

这是一套全面的网络组件

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, clMultiDC, clSingleDC, clDownLoader, clWebUpdate, RunUtils;

type
  TForm1 = class(TForm)
    btnStart: TButton;
    btnCancel: TButton;
    edtStatus: TEdit;
    clWebUpdate1: TclWebUpdate;
    clDownLoader1: TclDownLoader;
    procedure btnStartClick(Sender: TObject);
    procedure clWebUpdate1NoUpdatesFound(Sender: TObject);
    procedure clWebUpdate1DownloadProgress(Sender: TObject; UpdateNo,
      Downloaded, Total: Integer);
    procedure btnCancelClick(Sender: TObject);
    procedure clWebUpdate1Terminating(Sender: TObject;
      var CanTerminate: Boolean);
    procedure clWebUpdate1GetUpdateInfo(Sender: TObject; ActualInfo,
      UpdateInfo: TclUpdateInfoList);
    procedure clWebUpdate1Error(Sender: TObject; UpdateNo: Integer;
      const Error: String; ErrorCode: Integer);
    procedure clWebUpdate1HasUpdate(Sender: TObject;
      const AUpdateItem: TclUpdateInfoItem; ActualInfo: TclUpdateInfoList;
      var CanUpdate, Handled: Boolean);
    procedure clWebUpdate1RunUpdate(Sender: TObject;
      AUpdateScript: TStrings; ANeedTerminate: Boolean;
      var CanRun: Boolean; var Result: TclRunUpdateResult;
      var AErrors: String);
  private
    function GetTimeStamp(const AUrl, AUserName, APassword: string): string;
    procedure OpenMainApp;
    procedure CloseMainApp;
    function MainAppOpened: Boolean;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.btnStartClick(Sender: TObject);
begin
  edtStatus.Text := 'Checking for new updates...';
  clWebUpdate1.Start();
end;

procedure TForm1.btnCancelClick(Sender: TObject);
begin
  clWebUpdate1.Stop();
end;

procedure TForm1.clWebUpdate1NoUpdatesFound(Sender: TObject);
begin
  edtStatus.Text := 'There are no new updates available.';
end;

procedure TForm1.clWebUpdate1DownloadProgress(Sender: TObject; UpdateNo,
  Downloaded, Total: Integer);
begin
  edtStatus.Text := Format('Downloading %d update: %d %% completed...',
    [UpdateNo + 1, Downloaded * 100 div Total]);
end;

function TForm1.GetTimeStamp(const AUrl, AUserName, APassword: string): string;
begin
  Result := '';
  
  clDownLoader1.URL := AUrl;
  clDownLoader1.UserName := AUserName;
  clDownLoader1.Password := APassword;
  clDownLoader1.GetResourceInfo(False);

  if (clDownLoader1.Errors.Count > 0) or (clDownLoader1.ResourceInfo = nil) then Exit;

  Result := FloatToStr(clDownLoader1.ResourceInfo.Date);
end;

procedure TForm1.clWebUpdate1Terminating(Sender: TObject; var CanTerminate: Boolean);
begin
  CanTerminate := False;
  if not MainAppOpened() then
  begin
    OpenMainApp();
  end;
end;

procedure TForm1.OpenMainApp;
begin
  RunFile('MainApp.exe');
end;

procedure TForm1.CloseMainApp;
  function IsDelphiDesignTime(hwnd: THandle): Boolean;
  var
    h: THandle;
    s: array[0..256] of Char;
  begin
    Result := False;
    
    h := GetWindow(hwnd, GW_OWNER);
    if (h = 0) then Exit;

    GetWindowText(h, s, SizeOf(s));
    Result := Pos('DELPHI', UpperCase(s)) > 0;
  end;
  
var
  hwnd: THandle;
begin
  repeat
    hwnd := FindWindow('TWebUpdateMainAppForm', 'Web Update Main Application');
    if (hwnd = 0) then Break;

    if IsDelphiDesignTime(hwnd) then
    begin
      ShowMessage('Cannot close Delphi designer for TWebUpdateMainAppForm, please close it manually.');
      Break;
    end;
    
    SendMessage(hwnd, WM_CLOSE, 0, 0);
  until False;
end;

function TForm1.MainAppOpened: Boolean;
begin
  Result := (FindWindow('TWebUpdateMainAppForm', 'Web Update Main Application') <> 0);
end;

procedure TForm1.clWebUpdate1GetUpdateInfo(Sender: TObject; ActualInfo,
  UpdateInfo: TclUpdateInfoList);
var
  i: Integer;
begin
  //prepare previously failed updates to re-run 
  for i := 0 to ActualInfo.Count - 1 do
  begin
    if (ActualInfo[i].Status = usFailed) then
    begin
      ActualInfo[i].Status := usReady;
    end;
  end;
end;

procedure TForm1.clWebUpdate1Error(Sender: TObject; UpdateNo: Integer;
  const Error: String; ErrorCode: Integer);
begin
  edtStatus.Text := Error;
end;

procedure TForm1.clWebUpdate1HasUpdate(Sender: TObject;
  const AUpdateItem: TclUpdateInfoItem; ActualInfo: TclUpdateInfoList;
  var CanUpdate, Handled: Boolean);
  function LastItemByUrl(const AUrl: string): TclUpdateInfoItem;
  var
    i: Integer;
  begin
    for i := ActualInfo.Count - 1 downto 0 do
    begin
      if SameText(AUrl, ActualInfo[i].URL) then
      begin
        Result := ActualInfo[i];
        Exit;
      end;
    end;
    Result := nil;
  end;

var
  ActialItem: TclUpdateInfoItem;
begin
  ActialItem := LastItemByUrl(AUpdateItem.URL);

  AUpdateItem.Version := GetTimeStamp(AUpdateItem.URL, clWebUpdate1.UserName, clWebUpdate1.Password);

  CanUpdate := (ActialItem = nil)
    or (StrToFloatDef(ActialItem.Version, 0) < StrToFloatDef(AUpdateItem.Version, 0));

  if CanUpdate and (ActialItem <> nil) then
  begin
    ActialItem.Free();
  end;
  Handled := True;
end;

procedure TForm1.clWebUpdate1RunUpdate(Sender: TObject;
  AUpdateScript: TStrings; ANeedTerminate: Boolean; var CanRun: Boolean;
  var Result: TclRunUpdateResult; var AErrors: String);
begin
  if ANeedTerminate and MainAppOpened() then
  begin
    if (MessageDlg('To apply the update you need to close the application. Do you want to close ?',
      mtConfirmation, [mbYes, mbNo], 0) = mrYes) then
    begin
      CloseMainApp();
    end;
  end;
end;

end.