UrlDownloadFile, 线程下载文件, 带进度条

unit FileDownLoadThread;

interface

uses

  Classes,

  SysUtils,

  Windows,

  ActiveX,

  UrlMon;

const

  S_ABORT = HRESULT($80004004);



type

  TFileDownLoadThread = class;   

  TDownLoadProcessEvent = procedure(Sender: TFileDownLoadThread; Progress, ProgressMax: Cardinal) of object;

  TDownLoadCompleteEvent = procedure(Sender: TFileDownLoadThread) of object;

  TDownLoadFailEvent = procedure(Sender: TFileDownLoadThread; Reason: LongInt) of object;

  TDownLoadMonitor = class(TInterfacedObject, IBindStatusCallback)

  private

    FShouldAbort: Boolean;

    FThread: TFileDownLoadThread;

  protected

    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;

  public

    constructor Create(AThread: TFileDownLoadThread);

    property ShouldAbort: Boolean read FShouldAbort write FShouldAbort;

  end;

  TFileDownLoadThread = class(TThread)

  private

    FSourceURL: string;

    FSaveFileName: string;

    FProgress, FProgressMax: Cardinal;

    FOnProcess: TDownLoadProcessEvent;

    FOnComplete: TDownLoadCompleteEvent;

    FOnFail: TDownLoadFailEvent;

    FMonitor: TDownLoadMonitor;

  protected

    procedure Execute; override;

    procedure UpdateProgress(Progress, ProgressMax, StatusCode: Cardinal; StatusText: string);

    procedure DoUpdateUI;

  public

    constructor Create(ASrcURL, ASaveFileName: string; AProgressEvent: TDownLoadProcessEvent = nil; ACompleteEvent: TDownLoadCompleteEvent = nil; AFailEvent: TDownLoadFailEvent = nil; CreateSuspended: Boolean = False);

    property SourceURL: string read FSourceURL;

    property SaveFileName: string read FSaveFileName;

    property OnProcess: TDownLoadProcessEvent read FOnProcess write FOnProcess;

    property OnComplete: TDownLoadCompleteEvent read FOnComplete write FOnComplete;

    property OnFail: TDownLoadFailEvent read FOnFail write FOnFail;

  end;

implementation



constructor TDownLoadMonitor.Create(AThread: TFileDownLoadThread);

begin

  inherited Create;

  FThread := AThread;

  FShouldAbort := False;

end;



function TDownLoadMonitor.GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo): HResult;

begin

  result := S_OK;

end;



function TDownLoadMonitor.GetPriority(out nPriority): HResult;

begin

  Result := S_OK;

end;



function TDownLoadMonitor.OnDataAvailable(grfBSCF, dwSize: DWORD; formatetc: PFormatEtc; stgmed: PStgMedium): HResult;

begin

  Result := S_OK;

end;



function TDownLoadMonitor.OnLowResource(reserved: DWORD): HResult;

begin

  Result := S_OK;

end;



function TDownLoadMonitor.OnObjectAvailable(const iid: TGUID; punk: IInterface): HResult;

begin

  Result := S_OK;

end;



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

begin

  if FThread <> nil then FThread.UpdateProgress(ulProgress, ulProgressMax, ulStatusCode, '');

  if FShouldAbort then Result := E_ABORT else Result := S_OK;

end;



function TDownLoadMonitor.OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult;

begin

  Result := S_OK;

end;



function TDownLoadMonitor.OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult;

begin

  Result := S_OK;

end;

{ TFileDownLoadThread }



constructor TFileDownLoadThread.Create(ASrcURL, ASaveFileName: string; AProgressEvent: TDownLoadProcessEvent; ACompleteEvent: TDownLoadCompleteEvent; AFailEvent: TDownLoadFailEvent; CreateSuspended: Boolean);

begin

  if (@AProgressEvent = nil) or (@ACompleteEvent = nil) or (@AFailEvent = nil) then CreateSuspended := True;

  inherited Create(CreateSuspended);

  FSourceURL := ASrcURL;

  FSaveFileName := ASaveFileName;

  FOnProcess := AProgressEvent;

  FOnComplete := ACompleteEvent;

  FOnFail := AFailEvent;

end;



procedure TFileDownLoadThread.DoUpdateUI;

begin

  if Assigned(FOnProcess) then FOnProcess(Self, FProgress, FProgressMax);

end;



procedure TFileDownLoadThread.Execute;

var

  DownRet: HRESULT;

begin

  inherited;

  FMonitor := TDownLoadMonitor.Create(Self);

  DownRet := URLDownloadToFile(nil, PAnsiChar(FSourceURL), PAnsiChar(FSaveFileName), 0, FMonitor as IBindStatusCallback);

  if DownRet = S_OK then begin

    if Assigned(FOnComplete) then FOnComplete(Self);

  end else begin

    if Assigned(FOnFail) then FOnFail(Self, DownRet);

  end;

  FMonitor := nil;

end;



procedure TFileDownLoadThread.UpdateProgress(Progress, ProgressMax, StatusCode: Cardinal; StatusText: string);

begin

  FProgress := Progress;

  FProgressMax := ProgressMax;

  Synchronize(DoUpdateUI);

  if Terminated then FMonitor.ShouldAbort := True;

end;

end.  //使用unit Unit1;



interface



uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, StdCtrls, ComCtrls, UrlMon, FileDownLoadThread;



type

  TfrmDownloadFile = class(TForm)

    btn1: TButton;

    pb1: TProgressBar;

    lbl1: TLabel;

    lbl2: TLabel;

    procedure FormCreate(Sender: TObject);

    procedure btn1Click(Sender: TObject);

  private 

    aRunThread: TFileDownLoadThread;

  public

    SourceFile, DestFile: string;

    procedure DownLoadProcessEvent(Sender: TFileDownLoadThread; Progress, ProgressMax: Cardinal);

    procedure DownLoadCompleteEvent(Sender: TFileDownLoadThread);

    procedure DownLoadFailEvent(Sender: TFileDownLoadThread; Reason: LongInt);

  end;



var

  frmDownloadFile: TfrmDownloadFile;



implementation



{$R *.dfm}



procedure TfrmDownloadFile.FormCreate(Sender: TObject);

begin

  AppendMenu(GetSystemMenu(Handle, false), 0, 0, '程序: 花太香, QQ号: 2111971');

end;



procedure TfrmDownloadFile.btn1Click(Sender: TObject);

begin

  SourceFile := 'http://toolbar.soso.com/T4/download/QQToolbarInstaller.exe';

  DestFile := '.\QQToolbarInstaller.exe';

  lbl1.Caption := '0/0';

  lbl2.Caption := '';

  pb1.Position := 0;

  lbl2.Caption := '正在下载：' + ExtractFileName(DestFile);

  aRunThread := TFileDownLoadThread.Create(SourceFile, DestFile, DownLoadProcessEvent, DownLoadCompleteEvent, DownLoadFailEvent, False);

end;



procedure TfrmDownloadFile.DownLoadProcessEvent(

  Sender: TFileDownLoadThread; Progress, ProgressMax: Cardinal);

var

  z, z1: Single;

  s, s1: string;

begin

  pb1.Position := Progress;

  pb1.Max := ProgressMax;

  if (pb1.Max > 0) then

  begin

    if pb1.Max > 1024 * 1024 then begin

      z := pb1.Max / (1024 * 1024);

      s := 'MB';

    end else begin

      z := pb1.Max / (1024);

      s := 'KB';

    end;



    if Progress > 1024 * 1024 then begin

      z1 := Progress / (1024 * 1024);

      s1 := 'MB';

    end else begin

      z1 := Progress / (1024);

      s1 := 'KB';

    end;

    lbl1.Caption := Format('%.2n' + s1 + ' / %.2n' + s, [z1, z]);

  end;

end;



procedure TfrmDownloadFile.DownLoadCompleteEvent(

  Sender: TFileDownLoadThread);

begin

  lbl2.Caption := '下载完成.';

  lbl1.Caption := '';

end;



procedure TfrmDownloadFile.DownLoadFailEvent(Sender: TFileDownLoadThread; Reason: Integer);

begin

  lbl2.Caption := '下载文件失败，请重试!';

end;

end.