下载程序并且UrlDownloadToFile的进度提示
网上看到的转载过来，测试过确实没问题，正在简单增加下窗体功能。
urlmon.dll中有一个用于下载的API，MSDN中的定义如下：
HRESULT URLDownloadToFile(
LPUNKNOWN pCaller,
LPCTSTR szURL,
LPCTSTR szFileName,
DWORD dwReserved,
LPBINDSTATUSCALLBACK lpfnCB
);
Delphi的UrlMon.pas中有它的Pascal声明：
function URLDownloadToFile(
pCaller: IUnKnown,
szURL: PAnsiChar,
szFileName: PAnsiChar,
dwReserved: DWORD,
lpfnCB: IBindStatusCallBack;
);HRESULT;stdcall;
szURL是要下载的文件的URL地址，szFileName是另存文件名，dwReserved是保留参数，传递0。如果不需要进度提示的话，调用这个函数很简单。比如要下载http://218.95.47.224/page/jxzy/XSZB/web/fourteens/Music/qili.mp3 这首歌，并保存为D:\ Music\七里香.mp3，就可以这样调用：
URLDownloadToFile(nil,'http://218.95.47.224/page/jxzy/XSZB/web/fourteens/Music/qili.mp3 ','D:\ Music\七里香.mp3',0,nil);
不过这样做的缺点是没有进度提示，而且会阻塞调用线程。如果要获得进度提示就要用到最后一个参数lpfnCB了，它是一个接口类型IBindStatusCallBack，定义如下：
IBindStatusCallback = interface
['{79eac9c1-baf9-11ce-8c82-00aa004ba90b}']
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;
进度提示就靠这个接口的OnProgress方法了。我们可以定义一个实现 IBindStatusCallback 接口的类，只处理一下OnProgress方法就可以了，其它方法咱啥都不做，就返回S_OK。下面简要说一下OnProgress：
ulProgress ：当前进度值
ulProgressMax ：总进度
ulStatusCode: 状态值，是tagBINDSTATUS枚举。表明正在寻找资源啊，正在连接啊这些状态。具体请查看MSDN，我们这里不需要关心它
szStatusText：状态字符串，咱也不关心它
所以我们用百分比来表示进度的话就是FloatToStr(ulProgress*100/ulProgressMax)+'/%'，简单吧。
我把UrlDownloadToFile及其进度提示功能都封装进了一个线程类中，这个类的源码如下：
{ Delphi File Download Thread Class , Copyright (c) Zhou Zuoji }
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.
关于这个函数的用法CSDN的一段内容：
[Q]:URLDownloadToFile这个函数你用过吗？
[A]:没有
[Q]:其中最后一个参数不知怎样使用
[A]:看样子。你可以自己写一个类继承这个接口，然后将接口传给这个函数即可,绑定状态回调,
[Q]:var Status: IBindStatusCallback;
procedure DoDownloadFiles;
begin
....
OleCheck(URLDownloadToFile(nil, PChar(FDownLoadFile), PChar(FLocalTempFile), 0, Status));
...
end;
[A:]你的Status是什么,自己完成一个类
TTest = class(TInterfacedObject, IBindStatusCallback)
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;
function TTest.GetBindInfo(out grfBINDF: DWORD;
var bindinfo: TBindInfo): HResult;
begin
end;
function TTest.GetPriority(out nPriority): HResult;
begin
end;
function TTest.OnDataAvailable(grfBSCF, dwSize: DWORD;
formatetc: PFormatEtc; stgmed: PStgMedium): HResult;
begin
end;
function TTest.OnLowResource(reserved: DWORD): HResult;
begin
end;
function TTest.OnObjectAvailable(const iid: TGUID;
punk: IInterface): HResult;
begin
end;
function TTest.OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
szStatusText: LPCWSTR): HResult;
begin
ShowMessage(IntToStr(ulProgress) + '~~' + IntToStr(ulProgressMax) );
//这个值好像 有问题~~
end;
function TTest.OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult;
begin
end;
function TTest.OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult;
begin
end;
这个类还是按照一般方法创建,
但是你要传接口指针的时候这样写：
I := Test as IBindStatusCallback;假设Test是这个类的实例
获得的这个I就是需要的接口指针，可以直接传给那个函数
[Q]:我只要用到OnProgress是不是可以只继承这一个呀
[A]:不行。要全部继承，不过可以只在这个函数写代码
调用方法：
var
Status: TTest;
I: IBindStatusCallback;
procedure DoDownloadFiles;
begin
...
Status := TTest.Create;
I := Status as IBindStatusCallback;
OleCheck(URLDownloadToFile(nil, PChar(FDownLoadFile), PChar(FLocalTempFile), 0, I));
...
end
特别鸣谢：mshawk.
以上代码由CoolSlob整理所得(比较零乱，别骂我），建议大家收藏，我找遍了DFW都没找到~~
MSHawk：实际上编译器可以帮我们完成很多事情。可是大部分人都不愿意深入下去
呵呵:)所以同志们加紧学习呀~~~
更正：
function TTest.OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
szStatusText: LPCWSTR): HResult;
begin
ShowMessage(IntToStr(ulProgress) + '~~' + IntToStr(ulProgressMax) );
//刚刚测试过，这个值 没 问题~~嘻嘻
end;
这个问题太简单了，你早问我好了，呵呵，把我以前的代码贴出来吧，不然对不起这颗星啊！
//------------------------------------------------------------------------------
function TfrmMain.GetHTMLFile( URL , FileName : string) : HRESULT;
var
status : IBindStatusCallback ;
begin
status := IBindStatusCallback(self); //設定。
result := UrlDownLoadToFile(nil, pChar( URL ) ,pChar( FileName ),0 ,Status );
end;
//------------------------------------------------------------------------------
function TfrmMain.GetBindInfo(out grfBINDF: DWORD;
var bindinfo: TBindInfo): HResult;
begin
result := E_NOTIMPL;
end;
//------------------------------------------------------------------------------
function TfrmMain.GetPriority(out nPriority): HResult;
begin
result := E_NOTIMPL;
end;
//------------------------------------------------------------------------------
function TfrmMain.OnDataAvailable(grfBSCF, dwSize: DWORD;
formatetc: PFormatEtc; stgmed: PStgMedium): HResult;
begin
result := E_NOTIMPL;
end;
//------------------------------------------------------------------------------
function TfrmMain.OnLowResource(reserved: DWORD): HResult;
begin
result := E_NOTIMPL;
end;
//------------------------------------------------------------------------------
function TfrmMain.OnObjectAvailable(const iid: TGUID;
punk: IInterface): HResult;
begin
result := E_NOTIMPL;
end;
//-----------------------------------------------------------------------------
function TfrmMain.OnProgress(ulProgress, ulProgressMax,ulStatusCode: ULONG; szStatusText: LPCWSTR): HResult;
var
Status:string;
begin
case ulStatusCode of
1 : Status:=('BINDSTATUS_FINDINGRESOURCE');
2 : Status:=('BINDSTATUS_CONNECTING');
3 : Status:=('BINDSTATUS_REDIRECTING');
4 : Status:=('BINDSTATUS_BEGINDOWNLOADDATA');
5 : Status:=('BINDSTATUS_DOWNLOADINGDATA');
6 : Status:=('BINDSTATUS_ENDDOWNLOADDATA ');
7 : Status:=('BINDSTATUS_BEGINDOWNLOADCOMPONENTS');
8 : Status:=('BINDSTATUS_INSTALLINGCOMPONENTS' );
9 : Status:=('BINDSTATUS_ENDDOWNLOADCOMPONENTS');
10 : Status:=('BINDSTATUS_USINGCACHEDCOPY');
11 : Status:=('BINDSTATUS_SENDINGREQUEST');
12 : Status:=('BINDSTATUS_CLASSIDAVAILABLE');
13 : Status:=('BINDSTATUS_MIMETYPEAVAILABLE');
14 : Status:=('BINDSTATUS_CACHEFILENAMEAVAILABLE');
15 : Status:=('BINDSTATUS_BEGINSYNCOPERATION');
16 : Status:=('BINDSTATUS_ENDSYNCOPERATION');
17 : Status:=('BINDSTATUS_BEGINUPLOADDATA');
18 : Status:=('BINDSTATUS_UPLOADINGDATA');
19 : Status:=('BINDSTATUS_ENDUPLOADINGDATA');
20 : Status:=('BINDSTATUS_PROTOCOLCLASSID');
21 : Status:=('BINDSTATUS_ENCODING');
22 : Status:=('BINDSTATUS_VERFIEDMIMETYPEAVAILABLE');
23 : Status:=('BINDSTATUS_CLASSINSTALLLOCATION');
24 : Status:=('BINDSTATUS_DECODING');
25 : Status:=('BINDSTATUS_LOADINGMIMEHANDLER');
26 : Status:=('BINDSTATUS_CONTENTDISPOSITIONATTACH');
27 : Status:=('BINDSTATUS_FILTERREPORTMIMETYPE');
28 : Status:=('BINDSTATUS_CLSIDCANINSTANTIATE');
29 : Status:=('BINDSTATUS_IUNKNOWNAVAILABLE');
30 : Status:=('BINDSTATUS_DIRECTBIND');
31 : Status:=('BINDSTATUS_RAWMIMETYPE');
32 : Status:=('BINDSTATUS_PROXYDETECTING');
33 : Status:=('BINDSTATUS_ACCEPTRANGES');
end;
if DoCancel then
result := E_ABORT
else
result :=S_OK;
end;
