(1)接下来我们来写最主要的代码,也就是下载部分了,首先来看HTTP协议的:
- procedure HttpDownLoad(const IdHTTP1:TIdHTTP;const aURL, aFile: string; const bResume: Boolean);
- var
- tStream: TFileStream;
- begin
- if not CheckUrlFileExists(aURL) then
- begin
- MessageBox(0, '处理操作失败,服务器上文件不存在!', '系统提示', MB_OK
- + MB_ICONSTOP + MB_TOPMOST);
- Exit;
- end;
- if FileExists(aFile) then
- tStream := TFileStream.Create(aFile, fmOpenWrite) else
- tStream := TFileStream.Create(aFile, fmCreate);
-
- if bResume then
- begin
- IdHTTP1.Request.ContentRangeStart := tStream.Size - 1;
- tStream.Position := tStream.Size - 1;
- IdHTTP1.Head(aURL);
- IdHTTP1.Request.ContentRangeEnd := IdHTTP1.Response.ContentLength;
- end else
- begin
- IdHTTP1.Request.ContentRangeStart := 0;
- end;
-
- try
- IdHTTP1.Get(aURL, tStream);
- finally
- tStream.Free;
- end;
- end;
这里我们同样使用IdHTTP的Get过程,函数的aURL是网址,aFile是保存的文件名,bResume确定是否续传,需要注意的就是续传方式时的代码:
- IdHTTP1.Request.ContentRangeStart := tStream.Size - 1;
- tStream.Position := tStream.Size - 1;
- IdHTTP1.Head(aURL);
- IdHTTP1.Request.ContentRangeEnd := IdHTTP1.Response.ContentLength;
第一行我们将下载开始位置设置为读入文件流的末尾,也就是设置为已经下载了的那部分文件的大小,第二行我们将文件流本身也指向自己的末尾,第三行我们通过Head过程得到网址头信息,在第四行将头信息的文件总大小赋值给下载的结束的位置,至于这里为什么第一行和第二行代码最后都要-1,我当时没有加-1的时候在续下载一个完整的已经下载的文件的时候总是提示错误,最后跟踪IdHTTP的代码发现他在处理下载范围的时候如果开始的位置和结束位置一样时会引发将浮点数转为整数的错误,因而这里加上-1防止这种错误发生,另外一种处理方法就是比较如果开始位置等于结束位置就退出也是可以的。
再来看看要用到的几个检测函数:
- function CheckUrlFileExists(const aURL: string):Boolean;
-
- var
- hSession, hfile: hInternet;
- dwindex, dwcodelen: dword;
- dwcode: array[1..20] of Char;
- res: PChar;
- url:string;
- begin
- Result := false;
- url := aURL;
- if Pos('http://', LowerCase(url)) = 0 then
- url := 'http://' + url;
- hSession := InternetOpen('InetURL:/1.0', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
- if Assigned(hsession) then
- begin
- hfile := InternetOpenUrl(hsession, PChar(url), nil, 0, INTERNET_FLAG_RELOAD, 0);
- dwIndex := 0;
- dwCodeLen := 10;
- HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE, @dwcode, dwcodeLen, dwIndex);
- res := PChar(@dwcode);
- Result := (res = '200') or (res = '302');
- if Assigned(hfile) then
- InternetCloseHandle(hfile);
- InternetCloseHandle(hsession);
- end;
- end;
-
- function CheckFtpFileExists(const IdFTP:TIdFTP;const fn:string):Boolean;
- var
- listFTPFile:TStringList;
- begin
- Result := False;
- listFTPFile := TStringList.create;
- try
- try
- IdFTP.List(listFTPFile, ExtractFileName(fn));
- except
- end;
- if(listFTPFile.Count > 0) then
- begin
- Result := True;
-
- end;
- finally
- FreeAndNil(listFTPFile );
- end;
- end;
-
- function GetFileNameFromURL(const aURL: string): string;
- var ts : TStrings;
- begin
-
- ts := TStringList.create;
- try
- ts.Delimiter :='/';
- ts.DelimitedText := aURL;
- if ts.Count > 0 then
- Result := ts[ts.Count - 1];
- finally
- ts.Free;
- end;
- end;
再来看FTP协议的下载过程:
- procedure FtpDownLoad(const IdFTP1:TIdFTP;const aURL, aFile: string; bResume: Boolean);
- var
- tStream: TFileStream;
- sName, sPass, sHost, sPort, sDir: string;
- BytesToTransfer:Int64;
- begin
- if not CheckFtpFileExists(IdFTP1,aURL) then
- begin
- MessageBox(0, '处理操作失败,服务器上文件不存在!', '系统提示', MB_OK
- + MB_ICONSTOP + MB_TOPMOST);
- Exit;
- end;
- if FileExists(aFile) then
- tStream := TFileStream.Create(aFile, fmOpenWrite) else
- tStream := TFileStream.Create(aFile, fmCreate);
-
- GetFTPParams(aURL, sName, sPass, sHost, sPort, sDir);
- with IdFTP1 do
- try
- if Connected then Disconnect;
- Username := sName;
- Password := sPass;
- Host := sHost;
- Port := StrToInt(sPort);
- Connect;
- except
- exit;
- end;
-
- IdFTP1.ChangeDir(sDir);
- BytesToTransfer := IdFTP1.Size(aFile);
- try
- if bResume then
- begin
- tStream.Position := tStream.Size;
- IdFTP1.Get(aFile, tStream, True);
- end else
- begin
- IdFTP1.Get(aFile, tStream, False);
- end;
- finally
- tStream.Free;
- end;
- end;
这个过程中我们就用到了GetFTPParams()函数将网址的用户名、密码、主机地址、端口、路径等信息分离出来,IdFTP利用这些信息登陆服务器并到相应目录,最后利用Get()过程就很容易实现下载了,它的续传就比HTTP协议要简单很多,因为IdFTP的Get()本身就支持续传。
这里我简单穿插一点的内容,一个服务器是否支持断点续传,我们可以通过发送"REST 1"FTP指令来检测,如果返回350则表示支持。
最后我们根据网址来确定使用什么协议来下载:
- function GetProtocol(const aURL: string): Byte;
- begin
- Result := 0;
- if Pos('http', LowerCase(aURL)) = 1 then
- Result := 1;
- if Pos('ftp', LowerCase(aURL)) = 1 then
- Result := 2;
- end;
也可以使用TIdURI类,在IdURI.pas单元,这个类可以很轻松的将我们上面的GetProtocol()函数的功能实现,例如:
- function GetFTPParams(const aURL:string;out sProtocol, sName, sPass, sHost, sPort, sDir:string):Boolean;
- var
- URI: TIdURI;
- begin
- URI := TIdURI.Create(aURL);
- try
- sProtocol := URI.Protocol;
- sHost := URI.Host;
- sName := URI.Username;
- sPass := URI.Password;
- sPort := URI.Port;
- if sPort='' then
- sPort := '21';
- sDir := URI.Path;
-
-
- finally
- URI.Free;
- end;
- end;
这个函数根据URL网址返回整数供我们使用,例如我们可以。
- procedure TMainForm.DownLoadFile(const aURL, aFile: string; const bResume: Boolean);
- begin
- case GetProtocol(aURL) of
- 0: ShowMessage('不可识别的地址!');
- 1: HttpDownLoad(IdHTTP1, aURL, aFile, bResume);
- 2: FtpDownLoad(IdFTP1, aURL, aFile, bResume);
- end;
- end;
这个过程就利用GetProtocol()函数返回的整数执行相应的协议下载过程。
好么如何实现FTP协议的上传呢?
- procedure FtpUpLoad(const IdFTP1:TIdFTP;const aURL, aFile: string; const bResume: Boolean);
- var
-
- sProtocol, sName, sPass, sHost, sPort, sDir: string;
- BytesToTransfer:Int64;
- dFile:string;
- begin
- if not FileExists(aFile) then
- Exit;
-
- GetFTPParams(aURL,sProtocol,sName, sPass, sHost, sPort, sDir);
- with IdFTP1 do
- try
- if Connected then Disconnect;
- Username := sName;
- Password := sPass;
- Host := sHost;
- Port := StrToIntDef(sPort,21);
- Connect;
- except
- Exit;
- end;
- IdFTP1.TransferType := ftASCII;
- IdFTP1.ChangeDir(sDir);
- dFile := GetFileNameFromURL(aURL);
-
- if CheckFtpFileExists(IdFTP1,dFile) then
- begin
- if MessageBox(0,
- '服务器已存在同名文件,要继续上传并覆盖服务器上此文件吗?', '系统提示',
- MB_YESNO + MB_ICONWARNING + MB_DEFBUTTON2 + MB_TOPMOST) = IDNO then
- begin
- Exit;
- end;
- end;
-
- IdFTP1.TransferType := ftBinary;
- try
- try
- if bResume then
- begin
- IdFTP1.Put(aFile, dFile, True);
- end else
- begin
- IdFTP1.Put(aFile, dFile, False);
- end;
- except
- on e:Exception do
- begin
- if e.Message='' then
- MessageBox(0,
- '操作失败!请检查要上传的文件大小是否超过服务器的限制!',
- '系统提示', MB_OK + MB_ICONSTOP + MB_TOPMOST)
- else
- MessageBox(0,
- PChar('操作失败!'+e.Message),
- '系统提示', MB_OK + MB_ICONSTOP + MB_TOPMOST);
- IdFTP1.Delete(dFile);
- end;
- end;
- finally
-
- end;
- end;
(2) 接下来看看主窗口中每个按钮的代码,有了上面的函数,按钮的代码就简单多了:
下载按钮:
- procedure TMainForm.Button1Click(Sender: TObject);
- var
- aURL, aFile: string;
- begin
- aURL := ComboBox1.Text;
- aFile := GetURLFileName(aURL);
- if FileExists(aFile) then
- begin
- case MessageDlg('本地文件已经存在,是否续传?', mtConfirmation, mbYesNoCancel, 0) of
- mrYes: DownLoadFile(aURL, aFile, True);
- mrNo: DownLoadFile(aURL, aFile, False);
- mrCancel: Exit;
- end;
- end else DownLoadFile(aURL, aFile, False);
- end;
MessageDlg()函数弹出一个对话框让用户选择续传、覆盖还是取消下载。
中断按钮:
- procedure TMainForm.Button2Click(Sender: TObject);
- begin
- AbortTransfer := True;
- end;
前面忘了介绍,所以这里大家看不明白,AbortTransfer是我们定义的一个私有变量,在开始下载的时候将它设为False,下载的过程中随时监测这个变量,一旦变为True就利用IdHTTP的Disconnect和IdFTP1的Abort方法中断下载,如果没有下载完就中断,那程序的目录中就会有一个下载不完整的程序或者其他东西,下次再下载的时候我们就可以选择续传来完成剩下的下载过程。
- procedure TMainForm.IdHTTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
- const AWorkCountMax: Integer);
- begin
- AbortTransfer := False;
-
- end;
在IdHTTP1和IdFTP的OnWorkBegin事件我们就将AbortTransfer设置为False了,在他们的Work事件中,我们检测AbortTransfer变量来完成是否中断的操作。
- procedure TMainForm.IdHTTP1Work(Sender: TObject; AWorkMode: TWorkMode;
- const AWorkCount: Integer);
- begin
- if AbortTransfer then
- begin
- IdHTTP1.Disconnect;
- IdFTP1.Abort;
- end;
- ProgressBar1.Position := AWorkCount;
- Application.ProcessMessages;
- end;
(3) 最后是连接状态等信息的代码:
在IdHTTP和IdFTP的OnStatus事件写入:
- procedure TMainForm.IdHTTP1Status(ASender: TObject; const AStatus: TIdStatus;
- const AStatusText: string);
- var
- msg:string;
- begin
- case AStatus of
- hsResolving: msg := '正在解析数据……';
- hsConnecting: msg := '正在连接服务器……';
- hsConnected: msg := '服务器连接成功!';
- hsDisconnecting: msg := '正在断开与服务器的连接……';
- hsDisconnected: msg := '服务器连接已断开!';
- hsStatusText: msg := '正在切换服务器状态……';
- ftpTransfer: msg := '正在传输数据……';
- ftpReady: msg := '操作完成,数据传输OK!';
- ftpAborted: msg := '任务被中止!';
- end;
- ListBox1.ItemIndex := ListBox1.Items.Add(msg);
- end;
在IdHTTP和IdFTP的OnWordEnd事件写入:
- procedure TMainForm.IdFTP1WorkEnd(ASender: TObject; AWorkMode: TWorkMode);
- begin
- if AWorkMode=wmWrite then
- begin
- if ASender is TIdFTP then
- MessageBox(Handle, '操作结束,数据传输完成!', '系统提示', MB_OK +
- MB_ICONINFORMATION + MB_TOPMOST);
- end;
- end;
因为IdHTTP和IdFTP在OnWork、OnStatus等事件上执行的代码都是一样的,所以我们只用写其中一个的代码,然后另外一个选择相同的事件就OK了。
(3)全部代码写完收工,F9运行一下看看效果,是不是能断点续传。
本程序主要的功能由IdHTTP和IdFTP组件完成,主要掌握他们的Get过程实现断点续传的方法以及字符串的分析分解方法,这里我们同样使用了流格式,不过这次不是内存流而是文件流。通过本例,读者应该初步掌握调试程序时断点的使用,事件代码的共用等。 使用此类我们的程序可以变得更简单,如何修改就留给读者自己去完善吧。
(4)做了一个简单的DEMO,可以参考一下。