获取网络文件大小
//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;
程序结束