单线程文件下载

【实例截图】

【核心代码】

unit U_TDownFile;

interface
  uses SysUtils, Windows, UrlMon, ActiveX,Classes,shellapi;

  type  //下载流量状态回调接口类
    TOnProgressEvent = procedure(ulProgress, ulProgressMax, ulStatusCode: integer;szStatusText:String) of object;
    TOnCompleteEvent = procedure(Source_file,Dest_file:String;blStatus:boolean;ErrMessage:String) of object;

    TBindStatusCallback = class(TObject, IBindStatusCallback)
      protected // IUnknown
        FRefCount: Integer;
        function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
        function _AddRef: Integer; stdcall;
        function _Release: Integer; stdcall;
      public  // IBindStatusCallback
        FProgress : TOnProgressEvent;
        FComplete : TOnCompleteEvent;
        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;


    TThreadDown =class(TThread) //下载线程类。
      private
        Source_file : string;
        Dest_file   : string;
        StatusCallback : TBindStatusCallback;
      protected
        procedure Execute; override;
      public
        constructor Create(URL,FileName: String ; StatusCB: TBindStatusCallback);overload;
    end;


    TDownFile=class(TComponent) //文件下载控件
      private
        FOnProgress: TOnProgressEvent;
        RevedByte  : TBindStatusCallback;
        FOnComplete: TOnCompleteEvent;
        procedure SetOnProgress(const Value: TOnProgressEvent);  //下载进度
        procedure SetOnComplete(const Value: TOnCompleteEvent);  //下载完成
      public
        constructor Create(AOwner: TComponent);reintroduce;
        destructor Destroy; reintroduce;
        procedure  ThreadDownFile(Source,Dest:string);
        procedure DownFile(Source,Dest:string);
      published
        property  OnComplete:TOnCompleteEvent read FOnComplete write SetOnComplete;
        property  OnProgress:TOnProgressEvent read FOnProgress write SetOnProgress;
    end;
implementation

{ TBindStatusCallback }
function TBindStatusCallback._AddRef: Integer;
begin
  Inc(FRefCount);
  Result := FRefCount;
end;

function TBindStatusCallback._Release: Integer;
begin
  Dec(FRefCount);
  Result := FRefCount;
end;

function TBindStatusCallback.GetBindInfo(out grfBINDF: DWORD;
  var bindinfo: TBindInfo): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.GetPriority(out nPriority): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.OnDataAvailable(grfBSCF, dwSize: DWORD;
  formatetc: PFormatEtc; stgmed: PStgMedium): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.OnLowResource(reserved: DWORD): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.OnObjectAvailable(const iid: TGUID;
  punk: IInterface): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.OnStartBinding(dwReserved: DWORD;
  pib: IBinding): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.OnStopBinding(hresult: HResult;
  szError: LPCWSTR): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.QueryInterface(const IID: TGUID;
  out Obj): Integer;
begin
 if GetInterface(IID, Obj) then Result := S_OK
                           else Result := E_NOINTERFACE;
end;

function TBindStatusCallback.OnProgress(ulProgress, ulProgressMax,
  ulStatusCode: ULONG; szStatusText: LPCWSTR): HResult;
begin
  if Assigned(FProgress) then
    FProgress(ulProgress,ulProgressMax,ulStatusCode,szStatusText);
  Result := S_OK;
end;



//=============================================================================

{ TDownFile }

constructor TDownFile.Create(AOwner: TComponent);
begin
  RevedByte:=TBindStatusCallback.Create;
  inherited;
end;

destructor TDownFile.Destroy;
begin
  RevedByte.Free; 
end;

procedure TDownFile.SetOnComplete(const Value: TOnCompleteEvent);
begin
  FOnComplete := Value;
  if Assigned(FOnComplete) then ;
    RevedByte.FComplete := FOnComplete;
end;

procedure TDownFile.SetOnProgress(const Value: TOnProgressEvent);
begin
  FOnProgress := Value;
  if Assigned(FOnProgress) then  ;
    RevedByte.FProgress := FOnProgress;
end;

procedure TDownFile.ThreadDownFile(Source, Dest: string);
var
  ThreadDown:TThreadDown;
begin
  ThreadDown:=TThreadDown.Create(Source, Dest,RevedByte);
  ThreadDown.Resume;
end;

procedure TDownFile.DownFile(Source, Dest: string);
var
  blDownOK:boolean;
  ErrMessage:String;
begin
  ErrMessage:='';
  blDownOK:=false;
  try
    if UrlDownloadToFile(nil,Pchar(Source),Pchar(Dest),0,RevedByte)=0 then
      blDownOK:=true;
  except on e:exception do
    ErrMessage:=e.Message; 
  end;
  if Assigned(RevedByte.FComplete) then
     RevedByte.FComplete(Source,Dest,blDownOK,ErrMessage);
end;


//==============================================================================
{ TThreadDown }

constructor TThreadDown.Create(URL, FileName: String;StatusCB: TBindStatusCallback);
begin
  Source_file := URL;
  Dest_file   := FileName;
  StatusCallback := StatusCB;
  FreeOnTerminate:=true;
  inherited Create(true);
end;

procedure TThreadDown.Execute;
var
  blDownOK:boolean;
  ErrMessage:String;
begin
  ErrMessage:='';
  blDownOK:=false;
  try
    if UrlDownloadToFile(nil,Pchar(Source_file),Pchar(Dest_file),0,StatusCallback)=0 then
      blDownOK:=true;
  except on e:exception do
    ErrMessage:=e.Message; 
  end;
  if Assigned(StatusCallback.FComplete) then
     StatusCallback.FComplete(Source_file,Dest_file,blDownOK,ErrMessage);
end;

end.

.
├── P_RingAutoDown
│   ├── Form
│   │   ├── U_Main.dcu
│   │   ├── U_Main.ddp
│   │   ├── U_Main.dfm
│   │   ├── U_Main.pas
│   │   ├── U_RingSavePath.dcu
│   │   ├── U_RingSavePath.ddp
│   │   ├── U_RingSavePath.dfm
│   │   ├── U_RingSavePath.pas
│   │   ├── U_SysSet.dcu
│   │   ├── U_SysSet.ddp
│   │   ├── U_SysSet.dfm
│   │   └── U_SysSet.pas
│   ├── P_RingAutoDown.cfg
│   ├── P_RingAutoDown.dof
│   ├── P_RingAutoDown.dpr
│   ├── P_RingAutoDown.dproj
│   ├── P_RingAutoDown.dproj.local
│   ├── P_RingAutoDown.identcache
│   ├── P_RingAutoDown.res
│   ├── P_RingAutoDown.stat
│   ├── P_RingAutoDown_Icon.ico
│   ├── SysConfig.ini
│   └── Unit
│       ├── Cryptdef.inc
│       ├── GloVar.pas
│       ├── U_AddKeyToBuf.dcu
│       ├── U_AddKeyToBuf.pas
│       ├── U_CS_DealPack.dcu
│       ├── U_CS_DealPack.pas
│       ├── U_DBPublicPack.dcu
│       ├── U_DBPublicPack.pas
│       ├── U_DeleteKey.dcu
│       ├── U_DeleteKey.pas
│       ├── U_InnerDealPack.dcu
│       ├── U_InnerDealPack.pas
│       ├── U_ManagerTree.dcu
│       ├── U_ManagerTree.pas
│       ├── U_OtherPublicPack.dcu
│       ├── U_OtherPublicPack.pas
│       ├── U_PulicPack.dcu
│       ├── U_PulicPack.pas
│       ├── U_RecordStruct.dcu
│       ├── U_RecordStruct.pas
│       ├── U_StringPublicPack.dcu
│       ├── U_StringPublicPack.pas
│       ├── U_TDownFile.dcu
│       ├── U_TDownFile.pas
│       └── vssver.scc
└── 好例子网_网络音乐下载.zip

3 directories, 48 files