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.
UrlDownloadFile线程下载文件带进度条 https://www.gzza.com/2859.html
本网站资源来自互联网收集,仅供用于学习和交流,请勿用于商业用途。原创内容除特殊说明外,转载本站文章请注明出处。
如有侵权、不妥之处,联系删除。 Email:master@gzza.com
本网站资源来自互联网收集,仅供用于学习和交流,请勿用于商业用途。原创内容除特殊说明外,转载本站文章请注明出处。
如有侵权、不妥之处,联系删除。 Email:master@gzza.com
THE END