获取网络文件大小
//delphi 获取网络文件大小 function GetUrlFileSize(aURL: string): integer; var FileSize: integer; var IdHTTP: TidHttp; begin IdHTTP:= Tidhttp.Create(nil); IdHTTP.Head(aURL); FileSize := IdHTTP.Response.ContentLength; IdHTTP.Disconnect; Result := FileSize; end; //delphi 获取本地文件大小 function getFileSize(FileName:string):Longint; var SearchRec: TSearchRec; begin if FindFirst(ExpandFileName(FileName), faAnyFile, SearchRec) = 0 then Result := SearchRec.Size else Result := -1; end;
通用程序自动更新升级
1）服务端IIS网站上创建新的虚拟路径，给新创建的虚拟路径增加MIME类型：.bpl、.ini等。
2）设置update.ini文件版本号配置文件
[ver] config.ini=1 bplCommon.bpl=1 bplGoods.bpl=1 bplPower.bpl=1 bplPurchasing.bpl=1 prjMain.exe=2
3)客户端
untAutoUpdate.dfm文件：
object frmAutoUpdate: TfrmAutoUpdate Left = 0 Top = 0 Caption = #33258#21160#21319#32423#31243#24207 ClientHeight = 140 ClientWidth = 573 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'Tahoma' Font.Style = [] OldCreateOrder = False Position = poScreenCenter OnClose = FormClose OnCreate = FormCreate OnDestroy = FormDestroy OnShow = FormShow PixelsPerInch = 96 TextHeight = 13 object btnDownload: TButton Left = 199 Top = 24 Width = 138 Height = 41 Caption = #26816#26597#26356#26032 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -24 Font.Name = 'Tahoma' Font.Style = [] ParentFont = False TabOrder = 0 OnClick = btnDownloadClick end object bar: TProgressBar Left = 24 Top = 88 Width = 529 Height = 17 TabOrder = 1 end object cdsLocal: TClientDataSet Aggregates = <> IndexFieldNames = 'filename' Params = <> Left = 48 Top = 8 object cdsLocalfilename: TStringField FieldName = 'filename' Size = 100 end object cdsLocalver: TIntegerField FieldName = 'ver' end end object cdsServer: TClientDataSet Aggregates = <> IndexFieldNames = 'filename' Params = <> Left = 120 Top = 8 object cdsServerfilename: TStringField FieldName = 'filename' Size = 100 end object cdsServerver: TIntegerField FieldName = 'ver' end end end
untAutoUpdate.pas文件：
{ ******************************************************* 单元功用：自动升级 单元设计：陈新光 设计日期：2014-11-17 单元修改： 修改日期： ******************************************************* } unit untAutoUpdate; interface uses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Winapi.UrlMon, Vcl.StdCtrls, System.IniFiles, Data.DB, Datasnap.DBClient, Vcl.ComCtrls, Wininet; type TfrmAutoUpdate = class(TForm) btnDownload: TButton; cdsLocal: TClientDataSet; cdsServer: TClientDataSet; cdsLocalfilename: TStringField; cdsLocalver: TIntegerField; cdsServerfilename: TStringField; cdsServerver: TIntegerField; bar: TProgressBar; procedure btnDownloadClick(Sender: TObject); procedure FormShow(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); private { Private declarations } appPath: string; urlPath: string; FList: TStringList; function DownloadFile(Source, Dest: string): Boolean; procedure InitCdsLocal; procedure InitCdsServer; procedure CreateLocalVer; procedure CreateServerVer; public { Public declarations } end; var frmAutoUpdate: TfrmAutoUpdate; implementation {$R *.dfm} { TForm1 } procedure TfrmAutoUpdate.btnDownloadClick(Sender: TObject); var Source, Dest: string; errCount: Integer; procedure _down; begin Source := urlPath + cdsServer.FieldByName('filename').Text; Dest := appPath + cdsServer.FieldByName('filename').Text; if not DownloadFile(Source, Dest) then begin Inc(errCount); ShowMessage(cdsServer.FieldByName('filename').Text + '下载失败'); end; end; begin errCount := 0; // 下载服务端的update.ini Source := urlPath + 'update.ini'; Dest := appPath + 'update2.ini'; if DownloadFile(Source, Dest) then // 下载update.ini 成功 begin // 生成服务端文件版本情况列表 CreateServerVer; if FileExists(appPath + 'update.ini') then // 本地有update.ini begin // 生成本地文件版本情况列表 CreateLocalVer; // 比对文件版本号决定哪些需要下载 bar.Max := cdsServer.RecordCount; cdsServer.First; while not cdsServer.Eof do begin if not cdsLocal.FindKey([cdsServer.FieldByName('filename').Text]) then // 新文件要下载 begin _down; end else begin if cdsServer.FieldByName('ver').AsInteger > // 版本号低的旧文件要下载 cdsLocal.FieldByName('ver').AsInteger then begin _down; end; end; cdsServer.Next; bar.Position := bar.Position +1; bar.Update; end; end else begin // 本地无update.ini 下载所有文件 bar.Max := cdsServer.RecordCount; cdsServer.First; while not cdsServer.Eof do begin _down; cdsServer.Next; bar.Position := bar.Position +1; bar.Update; end; end; // 更新本地update.ini CopyFile(PChar(appPath + 'update2.ini'), PChar(appPath + 'update.ini'), False); DeleteFile(appPath + 'update2.ini'); end else begin // 从服务器下载update.ini 失败 ShowMessage('下载update.ini失败'); Exit; end; if errCount = 0 then begin ShowMessage('更新程序成功'); end else ShowMessage('更新程序程序失败'); end; procedure TfrmAutoUpdate.CreateLocalVer; var ini: TIniFile; i: integer; begin ini := TIniFile.Create(appPath + 'update.ini'); try FList.Clear; ini.ReadSectionValues('ver', FList); for i := 0 to FList.Count - 1 do begin cdsLocal.Append; cdsLocal.FieldByName('filename').Text := Copy(FList[i], 1, pos('=', FList[i]) - 1); cdsLocal.FieldByName('ver').Text := Copy(FList[i], pos('=', FList[i]) + 1, length(FList[i])); cdsLocal.Post; end; finally ini.Free; end; end; procedure TfrmAutoUpdate.CreateServerVer; var ini: TIniFile; i: integer; begin ini := TIniFile.Create(appPath + 'update2.ini'); try FList.Clear; ini.ReadSectionValues('ver', FList); for i := 0 to FList.Count-1 do begin cdsServer.Append; cdsServer.FieldByName('filename').Text := Copy(FList[i], 1, pos('=', FList[i]) - 1); cdsServer.FieldByName('ver').Text := Copy(FList[i], pos('=', FList[i]) + 1, length(FList[i])); cdsServer.Post; end; finally ini.Free; end; end; function TfrmAutoUpdate.DownloadFile(Source, Dest: string): Boolean; begin try DeleteUrlCacheEntry(PChar(Source)); // 先要清空缓存 Result := UrlDownloadToFile(nil, PChar(Source), PChar(Dest), 0, nil) = 0; except Result := False; end; end; procedure TfrmAutoUpdate.FormClose(Sender: TObject; var Action: TCloseAction); begin Action := caFree; frmAutoUpdate:=nil; end; procedure TfrmAutoUpdate.FormCreate(Sender: TObject); begin FList :=TStringList.Create; end; procedure TfrmAutoUpdate.FormDestroy(Sender: TObject); begin FreeAndNil(FList); end; procedure TfrmAutoUpdate.FormShow(Sender: TObject); var ini: TIniFile; begin appPath := ExtractFilePath(Application.ExeName); // 升级文件的url path ini := TIniFile.Create(appPath + 'config.ini'); try urlPath := ini.ReadString('appServer', 'update', ''); finally ini.Free; end; InitCdsLocal; InitCdsServer; end; procedure TfrmAutoUpdate.InitCdsLocal; begin if not cdsLocal.Active then cdsLocal.CreateDataSet else cdsLocal.EmptyDataSet; end; procedure TfrmAutoUpdate.InitCdsServer; begin if not cdsServer.Active then cdsServer.CreateDataSet else cdsServer.EmptyDataSet; end; end.
Delphi做的软件自动更新
unit UnitUpG; interface uses Forms,Windows,SysUtils,Classes,Controls,URLMON, SHellAPi,iniFiles,Tlhelp32; procedure UpGrade; procedure KillExe; var SName:String; UpGradeB:Boolean; type TLANGANDCODEPAGE=record wLanguage,wCodePage:Word; end; PLANGANDCODEPAGE=^TLANGANDCODEPAGE; type TUpDateThread=class(TThread) protected procedure Execute;override; end; implementation uses UNIT1; function ShowVersion:String; var VerInfo:PChar; lpTranslate:PLANGANDCODEPAGE; FileName:String; VerInfoSize,cbTranslate:DWORD; VerValueSize:DWORD; Data:String; VerFileV:PChar; lpFileVersion:string; begin Result:='0.0.0.0'; FileName:=Application.ExeName; VerInfoSize:=GetFileVersionInfoSize(PChar(FileName),VerInfoSize); if VerInfoSize>0 then begin VerInfo:=AllocMem(VerInfoSize); GetFileVersionInfo(PChar(FileName),0,VerInfoSize,VerInfo); VerQueryValue(VerInfo, PChar('/VarFileInfo/Translation'), Pointer(lpTranslate),cbTranslate); if cbTranslate<>0 then begin Data := format('/StringFileInfo/%.4x%.4x/FileVersion',[lpTranslate^.wLanguage,lpTranslate^.wCodePage]);VerQueryValue(VerInfo, PAnsiChar(data),Pointer(VerFileV), VerValueSize); if VerValueSize <> 0 then begin SetString(lpFileVersion,VerFileV,VerValueSize-1); Result:=lpFileVersion; end; end; FreeMem(VerInfo,VerInfoSize); end else begin Result:='0.0.0.0'; Application.MessageBox(' ?,' ',MB_OK+MB_ICONSTOP); Application.Terminate; end; end; function KillTask(ExeFileName:string):integer; const PROCESS_TERMINATE = $0001; var ContinueLoop: BOOLean; FSnapshotHandle: THandle; FProcessEntry32: TProcessEntry32; begin Result :=0; FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); FProcessEntry32.dwSize := SizeOf(FProcessEntry32); ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32); while Integer(ContinueLoop) <> 0 do begin if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) = UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) = UpperCase(ExeFileName))) then Result := Integer(TerminateProcess(OpenProcess(PROCESS_TERMINATE,BOOL(0), FProcessEntry32.th32ProcessID),0)); ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32); end; CloseHandle(FSnapshotHandle); end; procedure TUpDateThread.Execute; var FindUD:Boolean; inifile:TiniFile; i,Num:integer; DownFile,FSaveFile:String; Name,Path,CliVersion,SerVersion:String; begin FindUD:=False; inifile:=TiniFile.Create(ExtractFilePath(Application.ExeName)+'UpDate.ini'); Num:=StrToInt(inifile.ReadString('Program Number','Num','')); for i:=1 to Num do begin Name:=inifile.ReadString('session'+inttostr(i),'Name',''); Path:=inifile.ReadString('session'+inttostr(i),'Path',''); SerVersion:=inifile.ReadString('session'+inttostr(i),'Version',''); CliVersion:=ShowVersion; if (Name=ExtractFileName(Application.ExeName)) and (CliVersion<>SerVersion) then begin FindUD:=True; DownFile:=Path+Name; SName:=DownFile; FSaveFile:=Application.ExeName; break; end; end; try DeleteFile(ExtractFilePath(Application.ExeName)+Name+'.old'); except On E:Exception do Application.MessageBox('鍒櫎鑸婄増鏈け鏁?','Error',MB_OK); end; if FindUD then begin if Application.MessageBox('?','',MB_OKCancel)=mrOK then begin if Application.MessageBox( ?'yes'',''No''',' ',MB_YESNO)=mrYes then begin Application.MessageBox('' ,' ',MB_OK); Application.ProcessMessages; Screen.Cursor:=crHourGlass; try ReNameFile(FSaveFile,FSaveFile+'.old'); except On E:Exception do Application.MessageBox('鎷疯矟鏂囦欢鍓湰澶辨晽!','Error',MB_OK); end; try URLDownloadToFile(nil,PAnsiChar(DownFile),PAnsiChar(FSaveFile),0,nil); ShellExecute(0, 'open', PChar(Name),PChar(ExtractFilePath(Application.ExeName)), nil, SW_SHOWNORMAL); KillTask(ExtractFileName(Application.ExeName)); except On E:Exception do begin ReNameFile(FSaveFile+'.old',FSaveFile); Application.MessageBox('涓嬭級澶辨晽!','Error',MB_OK); Screen.Cursor:=crDefault; end; end; end else begin UpGradeB:=True; end; end; end; iniFile.Free; end; procedure KillExe; var BatchFile: TextFile; BatchFileName: string; ProcessInfo: TProcessInformation; StartUpInfo: TStartupInfo; begin BatchFileName := ExtractFilePath(ParamStr(0)) + '_KillExe.bat'; AssignFile(BatchFile, BatchFileName); Rewrite(BatchFile); Writeln(BatchFile, 'del "' + ParamStr(0) + '.old"'); Writeln(BatchFile,'if exist "' + ParamStr(0) + '.old"' + ' goto try'); Writeln(BatchFile, 'del %0'); CloseFile(BatchFile); FillChar(StartUpInfo, SizeOf(StartUpInfo), $00); StartUpInfo.dwFlags := STARTF_USESHOWWINDOW; StartUpInfo.wShowWindow := SW_HIDE; if CreateProcess(nil, PChar(BatchFileName), nil, nil, False, IDLE_PRIORITY_CLASS, nil, nil, StartUpInfo, ProcessInfo) then begin CloseHandle(ProcessInfo.hThread); CloseHandle(ProcessInfo.hProcess); end; end; procedure UpGrade; var FSaveFile,DownFile:String; begin if UpGradeB then begin DownFile:=SName; FSaveFile:=Application.ExeName; Application.MessageBox(' ',' ',mb_OK); Application.ProcessMessages; Screen.Cursor:=crHourGlass; try DeleteFile(FSaveFile+'.old'); except On E:Exception do Application.MessageBox(' ?',' ',mb_OK); end; try ReNameFile(FSaveFile,FSaveFile+'.old'); except On E:Exception do Application.MessageBox('!','Error',mb_OK); end; try URLDownloadToFile(nil,PAnsiChar(DownFile),PAnsiChar(FSaveFile),0,nil); Screen.Cursor:=crdefault; Application.MessageBox('!','',mb_OK); except On E:Exception do begin ReNameFile(FSaveFile+'.old',FSaveFile); Application.MessageBox('?','Error',mb_OK); end; end; try KillExe; except On E:Exception do begin Application.MessageBox('','Error',mb_OK); end; end; end; end; end.
TCPIP 下载文件（分块下载，带进度条显示）
http://blog.sina.com.cn/myblacksky
////客户端 //CurFilePath:本地路径 //SerFilePath:服务器路径 //CurFileName:本地文件名 //SerFileName:服务器文件名 //ShowFlag:是否显示进度条窗口 Function Act_DownFiles(CurFilePath,SerFilePath,CurFileName,SerFileName:String;ShowFlag:Boolean):Boolean; var TemFileName,RecevFileName:String; rbyte:array[0..4096] of byte; sFile:TFileStream; iFileSize:integer; begin Result:=False; IdTCPClientDowFiles.Host :=serverip;//服务器的地址 if IdTCPClientDowFiles.Connected then IdTCPClientDowFiles.Disconnect; Try IdTCPClientDowFiles.Connect; except MessageBox(Handle,'服务器没有开启','提示',MB_OK); Result:=False; Exit; end; with IdTCPClientDowFiles do begin while Connected do begin Try TemFileName:=SerFilePath+SerFileName;//服务器路径加名称 WriteLn(TemFileName); //指定路径 RecevFileName:=ReadLn;//从服务器端获得文件名 if RecevFileName <> '文件不存在' then begin iFileSize:=IdTCPClientDowFiles.ReadInteger; sFile:=TFileStream.Create(CurFilePath+CurFileName,fmCreate); if ShowFlag then begin FrmProgress.Show; FrmProgress.PB1.Position:=0; FrmProgress.PB1.Max := iFileSize div 100 ; end; While iFileSize > 4096 do begin IdTCPClientDowFiles.ReadBuffer(rbyte,4096);// .ReadBuffer(rbyte,iLen); sFile.Write(rByte,4096); inc(iFileSize,-4096); Application.ProcessMessages; if ShowFlag then begin FrmProgress.Label1.Caption:='正在下载：'+SerFileName; FrmProgress.PB1.Position:= FrmProgress.PB1.Position +(4096 div 100) ; end; end; if iFileSize > 0 then IdTCPClientDowFiles.ReadBuffer(rbyte,iFileSize);// .ReadBuffer(rbyte,iLen); Application.ProcessMessages; sFile.Write(rByte,iFileSize); if ShowFlag then begin FrmProgress.Close; end; sFile.Free; end; finally Disconnect;//断开连接 end; end; end; Result:=True; end; ////服务端 IdTCPServerGetFiles.Active:=True; procedure IdTCPServerGetFilesExecute(AThread: TIdPeerThread); var RecevFileName:string; iFileHandle:integer; iFileLen,cnt:integer; buf:array[0..4096] of byte; begin if not AThread.Terminated and AThread.Connection.Connected then //注意这里 begin with AThread.Connection do begin Try RecevFileName:=AThread.Connection.ReadLn;//获取文件全路径 if FileExists(RecevFileName) then begin Try WriteLn(RecevFileName);//发送全路径 iFileHandle:=FileOpen(RecevFileName,fmOpenRead); //得到此文件大小 iFileLen:=FileSeek(iFileHandle,0,2); FileSeek(iFileHandle,0,0); AThread.Connection.WriteInteger(iFileLen,True);////hjh 20071009 while iFileLen >0 do begin if IFileLen > 4096 then begin cnt:=FileRead(iFileHandle,buf,4096); AThread.Connection.WriteBuffer(buf,cnt,True);/////hjh20071009 iFileLen:=iFileLen-cnt; end else begin cnt:=FileRead(iFileHandle,buf,iFileLen); AThread.Connection.WriteBuffer(buf,cnt,True);/////hjh20071009 iFileLen:=iFileLen-cnt; end; end; Finally FileClose(iFileHandle); end; end else begin WriteLn('文件不存在'); end; Finally Disconnect;//断开连接 end; end; end; end;
WinInet带进度下载Http文件
function FileSize(SizeInBytes: dword): string; const Formats: array[0..3] of string = (' Bytes', ' KB', ' MB', ' GB'); FormatSpecifier: array[Boolean] of string = ('%n', '%.2n'); var iLoop: integer; TempSize: Real; begin iLoop := -1; TempSize := SizeInBytes; while (iLoop <= 3) do begin TempSize := TempSize / 1024; inc(iLoop); if Trunc(TempSize) = 0 then begin TempSize := TempSize * 1024; Break; end; end; Result := Format(FormatSpecifier[((Frac(TempSize)*10) > 1)], [TempSize]); if Copy(Result, Length(Result) - 2, 3) = '.00' then Result := Copy(Result, 1, Length(Result) - 3); Result := Result + Formats[iLoop]; end; function ExtractURLSite(FileName: string): string; begin Result := Copy(FileName, 1, Pos('/', FileName) - 1); end; function ExtractURLPath(FileName: string): string; begin Result := Copy(FileName, Pos('/', FileName), Length(FileName) - Pos('/', FileName) + 1); end; function Split(Input: string; Deliminator: string; Index: integer): string; var StringLoop, StringCount: integer; Buffer: string; begin Buffer := ''; if Index < 1 then Exit; StringCount := 0; StringLoop := 1; while (StringLoop <= Length(Input)) do begin if (Copy(Input, StringLoop, Length(Deliminator)) = Deliminator) then begin Inc(StringLoop, Length(Deliminator) - 1); Inc(StringCount); if StringCount = Index then begin Result := Buffer; Exit; end else begin Buffer := ''; end; end else begin Buffer := Buffer + Copy(Input, StringLoop, 1); end; Inc(StringLoop, 1); end; Inc(StringCount); if StringCount < Index then Buffer := ''; Result := Buffer; end; function ThreadProc(lpParam: Pointer): DWORD; stdcall; const BufferSize = 1024; Agent = 'Internet Explorer 9.9'; var Session, Connect, Resource, OpenUrl: HINTERNET; Buffer: array[1..BufferSize] of Byte; BufferLen: DWORD; f: File; FileSize, ReseRved, _SizeOf, ReadSize:DWORD; UrlFile, FileName, Site, URL, Location: string; begin FileName:= 'c:\x.exe'; Result:=0; UrlFile := 'http://xxxxxxxxxxxx/xxxxxxx.exe'; Location := Split(UrlFile, '://', 2); URL := ExtractURLPath(Location); Site := ExtractURLSite(Location); Session := InternetOpenA(PAnsiChar(Agent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); if Assigned(Session) then begin try Connect := InternetConnectA(Session, PAnsiChar(Site), INTERNET_DEFAULT_HTTP_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 0); if Assigned(Connect) then begin try Resource := HttpOpenRequestA(Connect, 'HEAD', PChar(URL), nil, nil, nil, 0, 0); if Assigned(Resource) then begin try if HttpSendRequestA(Resource, nil, 0, nil, 0) then begin _SizeOf := SizeOf(FileSize); //在下面api里直接用SizeOf 就说类型不一样- -! ReseRved := 0; FileSize := 0; ReadSize := 0; if (HttpQueryInfoA(Resource, HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER, @FileSize, _SizeOf, ReseRved)) and (FileSize <> 0) then begin try OpenUrl := InternetOpenUrlA(Session, PAnsiChar(UrlFile), nil,0,0,0); if Assigned(OpenUrl) then begin try AssignFile(f, FileName); Rewrite(f,1); repeat if InternetReadFile(OpenUrl, @Buffer,SizeOf(Buffer), BufferLen) then begin BlockWrite(f, Buffer, BufferLen); Inc(ReadSize,BufferLen); Form1.SkinGauge.Value:=ReadSize; end; until BufferLen = 0; CloseFile(f); finally InternetCloseHandle(OpenUrl) end end; finally end; end; end; finally InternetCloseHandle(Resource) end; end; finally InternetCloseHandle(Connect) end; end; finally InternetCloseHandle(Session) end; end; end; procedure TForm1.Button1Click(Sender: TObject); var ID: DWORD; begin CreateThread(nil, 0, @ThreadProc, nil, 0, ID); end;
TSeverSocket和TClientSocket组件安装
delphi 7,delphi2007 delphi 2009 delphi 2010的TSeverSocket和TClientSocket组件哪里去了 Borland is deprecating the use of the TServerSocket and TClientSocket from the unit ScktComp. It is recommended that you use the Indy components for socket operations. The TServerSocket and TClientSocket will no longer be installed on the component palette by default. If you require the use of these components then you can install the design time package named dclsockets70.bpl or dclsockets100.bpl dclsockets140.bpl , found in your bin directory. For deployment with runtime packages, you will need to deploy rtl70.bpl and any other required packages 偶简单翻译了一下:TClientSocket 本来是D5默认安装的,但是D7使用的Indy组件后,就没有默认安装了,如果你喜欢这个组件,可以在delphi 7,
delphi2007 delphi 2009 delphi 2010的安装目录bin文件夹找到dclsockets70.bpl or dclsockets100.bpl dclsockets140.bpl 组件包,安装上去就OK了.
dclsockets70.bpl or dclsockets100.bpl dclsockets140.bpl 是TCientSocket和TServerSocket必需的运行包.
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;
idHttp下载文件
procedure TForm1.Button3Click(Sender: TObject); var h:TIdhttp; res : String; MyStream:TMemoryStream; begin MyStream:=TMemoryStream.Create; h:=Tidhttp.Create(nil); try h.get('http://www.oro.com/project2.exe',MyStream); except showmessage('网络出错!'); MyStream.Free; exit; end; MyStream.SaveToFile('c:/1.exe'); MyStream.Free; end;
IDHTTP开发带进度条的下载程序
unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, StdCtrls,StrUtils,shellapi, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP, IdAntiFreezeBase, IdAntiFreeze; type TForm1 = class(TForm) DateTimePicker1: TDateTimePicker; ComboBox1: TComboBox; Button1: TButton; Button2: TButton; SaveDialog1: TSaveDialog; IdHTTP1: TIdHTTP; IdAntiFreeze1: TIdAntiFreeze; ProgressBar1: TProgressBar; StatusBar1: TStatusBar; procedure FormActivate(Sender: TObject); procedure Button2Click(Sender: TObject); procedure ComboBox1DropDown(Sender: TObject); procedure Button1Click(Sender: TObject); procedure IdHTTP1Work(Sender: TObject; AWorkMode: TWorkMode; const AWorkCount: Integer); procedure IdHTTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode; const AWorkCountMax: Integer); procedure IdHTTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode); procedure StatusBar1DrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect); private { Private declarations } public progressBarRect:TRect;{ Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} procedure TForm1.FormActivate(Sender: TObject); var fname,temps:string; ts:tstringlist; i:integer; begin comboBox1.Items.Clear; ts:=tstringlist.Create; fname:=ExtractFilePath(Application.ExeName)+'SID.txt'; try ts.LoadFromFile(fname); for i:=0 to ts.Count-1 do begin temps:=ts.Strings[i]; if(length(temps)>1) and (leftstr(temps,1)<>'#') then comboBox1.Items.Text:=comboBox1.Items.Text+temps end; finally ts.Free; if comboBox1.Items.Count>0 then comboBox1.ItemIndex:=0 end end; procedure TForm1.Button2Click(Sender: TObject); begin shellexecute(0,'open',pchar(ExtractFilePath(Application.ExeName)+'SID.txt'),nil,nil,SW_SHOW) end; procedure TForm1.ComboBox1DropDown(Sender: TObject); begin FormActivate(sender) end; procedure TForm1.Button1Click(Sender: TObject); var str,sid : string; MyStream:TMemoryStream; begin Button1.Enabled:=false; if savedialog1.Execute then begin statusbar1.panels[0].Text:='开始下载'; progressbar1.Visible:=true; progressbar1.Left:=progressBarRect.Left; progressbar1.top:=progressBarRect.top; progressbar1.width:=progressBarRect.Right-progressBarRect.Left; progressbar1.height:=progressBarRect.Bottom-progressBarRect.top; progressbar1.Parent:=statusbar1; IdAntiFreeze1.OnlyWhenIdle:=False;//设置使程序有反应. MyStream:=TMemoryStream.Create; str:=savedialog1.FileName; try IdHTTP1.Get(url,MyStream); except Showmessage('网络出错:'+IdHTTP1.ResponseText); MyStream.Free; statusbar1.panels[0].Text:=IdHTTP1.ResponseText; Button1.Enabled:=true; Exit; end; MyStream.SaveToFile(str); MyStream.Free; statusbar1.panels[0].Text:='下载完成'; progressbar1.Visible:=false; end; Button1.Enabled:=true; end; procedure TForm1.IdHTTP1Work(Sender: TObject; AWorkMode: TWorkMode; const AWorkCount: Integer); begin ProgressBar1.Position:=ProgressBar1.Position+AWorkCount; statusbar1.panels[0].Text:='已下载:'+inttostr(ProgressBar1.Position div 1024)+'K字节,总共:'+inttostr(ProgressBar1.Max div 1024)+'K字节,约'+inttostr(ProgressBar1.Position*100 div ProgressBar1.Max)+'%'; end; procedure TForm1.IdHTTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode; const AWorkCountMax: Integer); begin ProgressBar1.Max:=AWorkCountMax; ProgressBar1.Min:=0; ProgressBar1.Position:=0; end; procedure TForm1.IdHTTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode); begin ProgressBar1.Position:=ProgressBar1.Max; end; procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect); begin progressBarRect:=Rect; end; end.
实现FTP下载
unit WLFtp; interface uses Windows, Messages, Variants,SysUtils, Classes, Wininet, Dialogs; type TWLFtp = class(TObject) private FInetHandle: HInternet; // 句柄 FFtpHandle: HInternet; // 句柄 FHost: string; // 主机IP地址 FUserName: string; // 用户名 FPassword: string; // 密码 FPort: integer; // 端口 FCurrentDir: string; // 当前目录 public constructor Create;virtual; destructor Destroy;override; function Connect: boolean; function Disconnect: boolean; function UploadFile(RemoteFile: PChar; NewFile: PChar): boolean; function DownloadFile(RemoteFile: PChar; NewFile: PChar): boolean; function CreateDirectory(Directory: PChar): boolean; function LayerNumber(dir: string): integer; function MakeDirectory(dir: string): boolean; function FTPMakeDirectory(dir: string): boolean; function IndexOfLayer(index: integer; dir: string): string; function GetFileName(FileName: string): string; function GetDirectory(dir: string): string; property InetHandle: HInternet read FInetHandle write FInetHandle; property FtpHandle: HInternet read FFtpHandle write FFtpHandle; property Host: string read FHost write FHost; property UserName: string read FUserName write FUserName; property Password: string read FPassword write FPassword; property Port: integer read FPort write FPort; property CurrentDir: string read FCurrentDir write FCurrentDir; end; implementation //------------------------------------------------------------------------- // 构造函数 constructor TWLFtp.Create; begin inherited Create; end; //------------------------------------------------------------------------- // 析构函数 destructor TWLFtp.Destroy; begin inherited Destroy; end; //------------------------------------------------------------------------- // 链接服务器 function TWLFtp.Connect: boolean; begin try Result := false; // 创建句柄 FInetHandle := InternetOpen(PChar('KOLFTP'), 0, nil, nil, 0); FtpHandle := InternetConnect(FInetHandle, PChar(Host), FPort, PChar(FUserName), PChar(FPassword), INTERNET_SERVICE_FTP, 0, 255); if Assigned(FtpHandle) then begin Result := true; end; except Result := false; end; end; //------------------------------------------------------------------------- // 断开链接 function TWLFtp.Disconnect: boolean; begin try InternetCloseHandle(FFtpHandle); InternetCloseHandle(FInetHandle); FtpHandle:=nil; inetHandle:=nil; Result := true; except Result := false; end; end; //------------------------------------------------------------------------- // 上传文件 function TWLFtp.UploadFile(RemoteFile: PChar; NewFile: PChar): boolean; begin try Result := true; FTPMakeDirectory(NewFile); if not FtpPutFile(FFtpHandle, RemoteFile, NewFile, FTP_TRANSFER_TYPE_BINARY, 255) then begin Result := false; end; except Result := false; end; end; //------------------------------------------------------------------------- // 下载文件 function TWLFtp.DownloadFile(RemoteFile: PChar; NewFile: PChar): boolean; begin try Result := true; MakeDirectory(NewFile); if not FtpGetFile(FFtpHandle, RemoteFile, NewFile, True, FILE_ATTRIBUTE_NORMAL, FTP_TRANSFER_TYPE_BINARY OR INTERNET_FLAG_RELOAD, 255) then begin Result := false; end; except Result := false; end; end; //------------------------------------------------------------------------- // 创建目录 function TWLFtp.CreateDirectory(Directory: PChar): boolean; begin try Result := true; if FtpCreateDirectory(FFtpHandle, Directory)=false then begin Result := false; end; except Result := false; end; end; //------------------------------------------------------------------------- // 目录数 function TWLFtp.LayerNumber(dir: string): integer; var i: integer; flag: string; begin Result := 0; for i:=1 to Length(dir) do begin flag := Copy(dir,i,1); if (flag='\') or (flag='/') then begin Result := Result + 1; end; end; end; //------------------------------------------------------------------------- // 创建目录 function TWLFtp.FTPMakeDirectory(dir: string): boolean; var count, i: integer; SubPath: string; begin Result := true; count := LayerNumber(dir); for i:=1 to count do begin SubPath := IndexOfLayer(i, dir); if CreateDirectory(PChar(CurrentDir+SubPath))=false then begin Result := false; end; end; end; //------------------------------------------------------------------------- // 创建目录 function TWLFtp.MakeDirectory(dir: string): boolean; var count, i: integer; SubPath: string; str: string; begin Result := true; count := LayerNumber(dir); str := GetDirectory(dir); for i:=2 to count do begin SubPath := IndexOfLayer(i, str); if not DirectoryExists(SubPath) then begin if not CreateDir(SubPath) then begin Result := false; end; end; end; end; //------------------------------------------------------------------------- // 获取index层的目录 function TWLFtp.IndexOfLayer(index: integer; dir: string): string; var count, i: integer; ch: string; begin Result := ''; count := 0; for i:=1 to Length(dir) do begin ch := Copy(dir, i, 1); if (ch='\') or (ch='/') then begin count := count+1; end; if count=index then begin break; end; Result := Result + ch; end; end; //------------------------------------------------------------------------- // 获取文件名 function TWLFtp.GetFileName(FileName: string): string; begin Result := ''; while (Copy(FileName, Length(FileName), 1)<>'\') and (Length(FileName)>0) do begin Result := Copy(FileName, Length(FileName), 1)+Result; Delete(FileName, Length(FileName), 1); end; end; //------------------------------------------------------------------------- // 获取目录 function TWLFtp.GetDirectory(dir: string): string; begin Result := dir; while (Copy(Result, Length(Result), 1)<>'\') and (Length(Result)>0) do begin Delete(Result, Length(Result), 1); end; { if Copy(Result, Length), 1)='\' then begin Delete(Result, 1, 1); end;} end; //------------------------------------------------------------------------- end.
delphi从http服务器上下载文件
unit downloadTest; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,UrlMon; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} //文件下载 function DownloadFile(Source, Dest: string): Boolean; begin try Result := UrlDownloadToFile(nil, PChar(source), PChar(Dest), 0, nil) = 0; except Result := False; end; end; procedure TForm1.Button1Click(Sender: TObject); var filedir,downloadUrl:string; begin filedir :='D:\delphi\download\client.zip'; downloadUrl :='http://download.pingan.com.cn/bank/client.zip'; if DownloadFile(downloadUrl,filedir) then showMessage('文件下载成功') else showMessage('文件下载失败'); end; end.
多线程IdHttp下载网络上的文件并显示进度条
unit uTestThread; interface uses Classes, Windows, SysUtils, IdHTTP, IdComponent, Math, Messages; const WM_DownProgres = WM_USER + 1001; type TTestThread = class(TThread) private FIDHttp: TIdHTTP; FMaxProgres: Int64; FURL: string; FSavePath: string; FHandle: THandle; { Private declarations } procedure DoExecute; procedure DoWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Int64); procedure DoWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64); protected procedure Execute; override; public constructor Create(AURL, ASavePath: string; AHandle: THandle); destructor Destroy; override; end; implementation { TestThread } constructor TTestThread.Create(AURL, ASavePath: string; AHandle: THandle); begin FURL := AURL; FSavePath := ASavePath; FHandle := AHandle; FIDHttp := TIdHTTP.Create(nil); FIDHttp.OnWorkBegin := DoWorkBegin; FIDHttp.OnWork := DoWork; inherited Create(False); // 参数为False指线程创建后自动运行,为True则不自动运行 FreeOnTerminate := True; // 执行完毕后自动释放 end; destructor TTestThread.Destroy; begin FIDHttp.Free; inherited; end; procedure TTestThread.DoExecute; var FMs: TMemoryStream; begin FMs := TMemoryStream.Create; try FIDHttp.Get(FURL, FMs); FMs.SaveToFile(FSavePath); finally FMs.Free; end; end; procedure TTestThread.DoWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64); var ANowProgres: Integer; begin if FMaxProgres <> 0 then begin ANowProgres := Ceil(AWorkCount / FMaxProgres * 100); PostMessage(FHandle, WM_DownProgres, 0, ANowProgres); end; end; procedure TTestThread.DoWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Int64); begin FMaxProgres := AWorkCountMax; end; procedure TTestThread.Execute; begin DoExecute; end; end. 调用方法： type TForm7 = class(TForm) Gauge1: TGauge; Edit1: TEdit; Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } protected procedure DoWM_DownProgres(var Msg: TMessage); message WM_DownProgres; public { Public declarations } end; var Form7: TForm7; implementation {$R *.dfm} procedure TForm7.Button1Click(Sender: TObject); var FDownThread: TTestThread; begin FDownThread := TTestThread.Create(Edit1.Text, 'c:\testdown..zip', Self.Handle); end; procedure TForm7.DoWM_DownProgres(var Msg: TMessage); begin Gauge1.Progress := Msg.LParam; end;
实现文件下载的几种方法
开发的系统中的一个下载文件的功能，有一个API就可以搞定了，这个API就是UrlDownloadToFile。不仅如此，Delphi的一些控件也可以轻松实现下载，如NMHTTP，指定NMHTTP1.InputFileMode := ture; 指定Body为本地文件名，指定Get就可以下载了。下面是详细代码：
uses UrlMon; function DownloadFile(Source, Dest: string): Boolean; begin try Result := UrlDownloadToFile(nil, PChar(source), PChar(Dest), 0, nil) = 0; except Result := False; end; end; if DownloadFile('http://www.borland.com/delphi6.zip, 'c:\kylix.zip') then ShowMessage('Download succesful') else ShowMessage('Download unsuccesful')
例程：
Uses URLMon, ShellApi; function DownloadFile(SourceFile, DestFile: string): Boolean; begin try Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0, nil) = 0; except Result := False; end; end; procedure TForm1.Button1.Click(Sender: TObject); const // URL Location SourceFile := 'http://www.google.com/intl/de/images/home_title.gif'; // Where to save the file DestFile := 'c:\temp\google-image.gif'; begin if DownloadFile(SourceFile, DestFile) then begin ShowMessage('Download succesful!'); // Show downloaded image in your browser ShellExecute(Application.Handle,PChar('open'),PChar(DestFile),PChar(''),nil,SW_NORMAL) end else ShowMessage('Error while downloading ' + SourceFile) end;
加入如下代码：
NMHTTP1.InputFileMode := ture; NMHTTP1.Body := '本地文件名'; NMHTTP1.Header := 'Head.txt'; NMHTTP1.OutputFileMode := FALSE; NMHTTP1.ReportLevel := Status_Basic; NMHTTP1.Proxy := '代理服务器的IP地址'; NMHTTP1.ProxyPort := '代理服务器的端口号'; With NMHTTP1.HeaderInfo do Begin Cookie := ''; LocalMailAddress := ''; LocalProgram := ''; Referer := ''; UserID := '用户名称'; Password := '用户口令'; End; NMHTTP1.Get(‘http://www.abcdefg.com/software/a.zip');
试试吧，Delphi的目录中有TNMHTTP控件的例子。NT4+,Win95+,IE3+,你可以用URL Moniker的功能。
uses URLMon; ... OleCheck(URLDownloadToFile(nil,'URL','Filename',0,nil));
其中最后一个参数你还可以传入一个IBindStatusCallback的实现以跟踪下载进度或控制中止下载。简单的场合一句话就搞定了。
--回复得分 0--
BTW, URL Moniker封装了大多数URL，而不是像NMHTTP那样封装协议，因此你可以用URLDownloadToFile下载HTTP，FTP甚至本地文件和局域网文件，还有其他的custom moniker，比如MSITSTORE（MSDN Library的文档moniker实现）。
用IdHTTP控件吧！
var DownLoadFile:TFileStream; beginio DownLoadFile:=TFileStream.Create('c:\aa.rar',fmCreate); IdHTTP1.Get('http://www.sina.com.cn/download/aa.rar',DownLoadFile); DownLoadFile.Free; end;
程序结束
862
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
