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.