Delphi完成的断点续传例子 转

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, IdFTP, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdHTTP, IdHTTPHeaderInfo, ExtCtrls;
type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Panel1: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    Button1: TButton;
    ProgressBar1: TProgressBar;
    Button2: TButton;
    IdHTTP1: TIdHTTP;
    IdFTP1: TIdFTP;
    Button3: TButton;
    ComboBox1: TComboBox;
    procedure Button2Click(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 IdHTTP1Status(ASender: TObject; const AStatus: TIdStatus;
      const AStatusText: string);
    procedure Button3Click(Sender: TObject);
  private
    AbortTransfer: Boolean; //是否中断
    BytesToTransfer: LongWord; //下载总大小
    procedure FtpDownLoad(aURL, aFile: string; bResume: Boolean);
    procedure HttpDownLoad(aURL, aFile: string; bResume: Boolean);
    procedure MyDownLoad(aURL, aFile: string; bResume: Boolean);
    function GetProt(aURL: string): Byte;
    function GetURLFileName(aURL: string): string;
    procedure GetFTPParams(aURL: string; var sName, sPass, sHost, sPort,
      sDir: string);
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
var
  AverageSpeed: Double = 0;
implementation
{$R *.dfm}
procedure TForm1.Button2Click(Sender: TObject);
begin
  AbortTransfer := True;
end;
function TForm1.GetProt(aURL: string): Byte;
begin //检测下载的地址是http还是ftp
  Result := 0;
  if Pos('http', LowerCase(aURL)) = 1 then
    Result := 1; //http协议
  if Pos('ftp', LowerCase(aURL)) = 1 then
    Result := 2; //ftp协议
end;
function TForm1.GetURLFileName(aURL: string): string;
var
  i: integer;
  s: string;
begin //返回下载地址的文件名
  s := aURL;
  i := Pos('/', s);
  while i <> 0 do //去掉"/"前面的内容剩下的就是文件名了
  begin
    Delete(s, 1, i);
    i := Pos('/', s);
  end;
  Result := s;
end;
procedure TForm1.GetFTPParams(aURL: string; var sName, sPass, sHost, sPort, sDir: string);
var
  i, j: integer;
  s, tmp: string;
begin //分析ftp地址的登陆用户名，密码和目录
  s := aURL;
  if Pos('ftp://', LowerCase(s)) <> 0 then //去掉ftp头
    Delete(s, 1, 6);
  i := Pos('@', s);
  if i <> 0 then //地址含用户名，也可能含密码
  begin
    tmp := Copy(s, 1, i - 1);
    s := copy(s, i+1, Length(s));
    j := Pos(':', tmp);
    if j <> 0 then //包含密码
    begin
      sName := Copy(tmp, 1, j - 1); //得到用户名
      sPass := Copy(tmp, j + 1, i - j - 1); //得到密码
    end else
    begin
      sName := tmp;
      sPass := Inputbox('输入框','请输入登陆ftp密码','');
    end;
  end else //匿名用户
  begin
    sName := 'anonymous';
    sPass := 'test@ftp.com';
  end;
  i := Pos(':', s);
  j := Pos('/', s);
  sHost := Copy(s, 1, j - 1); //主机
  if i <> 0 then //含端口
    sPort := Copy(s, i + 1, j - i - 1) else
    sPort := '21'; //默认21端口
  tmp := Copy(s, j + 1, Length(s));
  while j <> 0 do
  begin
    Delete(s, 1, j);
    j := Pos('/', s);
  end; //目录
  sDir := '/' + Copy(tmp, 1, Length(tmp) - Length(s) - 1);
end;
procedure TForm1.FtpDownLoad(aURL, aFile: string; bResume: Boolean);
var
  tStream: TFileStream;
  sName, sPass, sHost, sPort, sDir: string;
begin //ftp方式下载
  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;
procedure TForm1.HttpDownLoad(aURL, aFile: string; bResume: Boolean);
var
  tStream: TFileStream;
begin //Http方式下载
  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;
procedure TForm1.MyDownLoad(aURL, aFile: string; bResume: Boolean);
begin
  case GetProt(aURL) of
    0: ShowMessage('不可识别的地址！');
    1: HttpDownLoad(aURL, aFile, bResume);
    2: FtpDownLoad(aURL, aFile, bResume);
  end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
  aURL, aFile: string;
begin
  aURL := ComboBox1.Text; //下载地址，例如"http://www.baidu.com/update/test.exe"
  aFile := GetURLFileName(aURL); //得到文件名，例如"test.exe"
  if FileExists(aFile) then
  begin
    case MessageDlg('文件已经存在，是否续传？', mtConfirmation, mbYesNoCancel, 0) of
      mrYes: MyDownLoad(aURL, aFile, True); //续传
      mrNo: MyDownLoad(aURL, aFile, False); //覆盖
      mrCancel: Exit; //取消
    end;
  end else MyDownLoad(aURL, aFile, False); //建立新文件下载
end;
procedure TForm1.IdHTTP1Work(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCount: Integer);
begin
  if AbortTransfer then
  begin //中断下载
    IdHTTP1.Disconnect;
    IdFTP1.Abort;
  end;
  ProgressBar1.Position := AWorkCount;
  Application.ProcessMessages;
end;
procedure TForm1.IdHTTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCountMax: Integer);
begin
  AbortTransfer := False;
  if AWorkCountMax > 0 then
    ProgressBar1.Max := AWorkCountMax else
    ProgressBar1.Max := BytesToTransfer;
end;
procedure TForm1.IdHTTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
begin
  ProgressBar1.Position := 0;
end;
procedure TForm1.IdHTTP1Status(ASender: TObject; const AStatus: TIdStatus;
  const AStatusText: string);
begin
  ListBox1.ItemIndex := ListBox1.Items.Add(AStatusText);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
  Close;
end;
end.

 

http://www.codefans.net/articles/1342.shtml

Delphi完成的断点续传例子，在网络应用中，断点续传是相当实用的，比如自动升级、或下载程序中，都可以用到。在Delphi7中，可以使用TIdHTTP和TIdFTP组件实现基于HTTP协议的断点续传和FTP协议的断点续传，都是使用的Indy系列组件，使用方法大同小异，下面来看运行效果图：

 

 

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, IdFTP, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdHTTP, IdHTTPHeaderInfo, ExtCtrls;
type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Panel1: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    Button1: TButton;
    ProgressBar1: TProgressBar;
    Button2: TButton;
    IdHTTP1: TIdHTTP;
    IdFTP1: TIdFTP;
    Button3: TButton;
    ComboBox1: TComboBox;
    procedure Button2Click(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 IdHTTP1Status(ASender: TObject; const AStatus: TIdStatus;
      const AStatusText: string);
    procedure Button3Click(Sender: TObject);
  private
    AbortTransfer: Boolean; //是否中断
    BytesToTransfer: LongWord; //下载总大小
    procedure FtpDownLoad(aURL, aFile: string; bResume: Boolean);
    procedure HttpDownLoad(aURL, aFile: string; bResume: Boolean);
    procedure MyDownLoad(aURL, aFile: string; bResume: Boolean);
    function GetProt(aURL: string): Byte;
    function GetURLFileName(aURL: string): string;
    procedure GetFTPParams(aURL: string; var sName, sPass, sHost, sPort,
      sDir: string);
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
var
  AverageSpeed: Double = 0;
implementation
{$R *.dfm}
procedure TForm1.Button2Click(Sender: TObject);
begin
  AbortTransfer := True;
end;
function TForm1.GetProt(aURL: string): Byte;
begin //检测下载的地址是http还是ftp
  Result := 0;
  if Pos('http', LowerCase(aURL)) = 1 then
    Result := 1; //http协议
  if Pos('ftp', LowerCase(aURL)) = 1 then
    Result := 2; //ftp协议
end;
function TForm1.GetURLFileName(aURL: string): string;
var
  i: integer;
  s: string;
begin //返回下载地址的文件名
  s := aURL;
  i := Pos('/', s);
  while i <> 0 do //去掉"/"前面的内容剩下的就是文件名了
  begin
    Delete(s, 1, i);
    i := Pos('/', s);
  end;
  Result := s;
end;
procedure TForm1.GetFTPParams(aURL: string; var sName, sPass, sHost, sPort, sDir: string);
var
  i, j: integer;
  s, tmp: string;
begin //分析ftp地址的登陆用户名，密码和目录
  s := aURL;
  if Pos('ftp://', LowerCase(s)) <> 0 then //去掉ftp头
    Delete(s, 1, 6);
  i := Pos('@', s);
  if i <> 0 then //地址含用户名，也可能含密码
  begin
    tmp := Copy(s, 1, i - 1);
    s := copy(s, i+1, Length(s));
    j := Pos(':', tmp);
    if j <> 0 then //包含密码
    begin
      sName := Copy(tmp, 1, j - 1); //得到用户名
      sPass := Copy(tmp, j + 1, i - j - 1); //得到密码
    end else
    begin
      sName := tmp;
      sPass := Inputbox('输入框','请输入登陆ftp密码','');
    end;
  end else //匿名用户
  begin
    sName := 'anonymous';
    sPass := 'test@ftp.com';
  end;
  i := Pos(':', s);
  j := Pos('/', s);
  sHost := Copy(s, 1, j - 1); //主机
  if i <> 0 then //含端口
    sPort := Copy(s, i + 1, j - i - 1) else
    sPort := '21'; //默认21端口
  tmp := Copy(s, j + 1, Length(s));
  while j <> 0 do
  begin
    Delete(s, 1, j);
    j := Pos('/', s);
  end; //目录
  sDir := '/' + Copy(tmp, 1, Length(tmp) - Length(s) - 1);
end;
procedure TForm1.FtpDownLoad(aURL, aFile: string; bResume: Boolean);
var
  tStream: TFileStream;
  sName, sPass, sHost, sPort, sDir: string;
begin //ftp方式下载
  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;
procedure TForm1.HttpDownLoad(aURL, aFile: string; bResume: Boolean);
var
  tStream: TFileStream;
begin //Http方式下载
  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;
procedure TForm1.MyDownLoad(aURL, aFile: string; bResume: Boolean);
begin
  case GetProt(aURL) of
    0: ShowMessage('不可识别的地址！');
    1: HttpDownLoad(aURL, aFile, bResume);
    2: FtpDownLoad(aURL, aFile, bResume);
  end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
  aURL, aFile: string;
begin
  aURL := ComboBox1.Text; //下载地址，例如"http://www.baidu.com/update/test.exe"
  aFile := GetURLFileName(aURL); //得到文件名，例如"test.exe"
  if FileExists(aFile) then
  begin
    case MessageDlg('文件已经存在，是否续传？', mtConfirmation, mbYesNoCancel, 0) of
      mrYes: MyDownLoad(aURL, aFile, True); //续传
      mrNo: MyDownLoad(aURL, aFile, False); //覆盖
      mrCancel: Exit; //取消
    end;
  end else MyDownLoad(aURL, aFile, False); //建立新文件下载
end;
procedure TForm1.IdHTTP1Work(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCount: Integer);
begin
  if AbortTransfer then
  begin //中断下载
    IdHTTP1.Disconnect;
    IdFTP1.Abort;
  end;
  ProgressBar1.Position := AWorkCount;
  Application.ProcessMessages;
end;
procedure TForm1.IdHTTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCountMax: Integer);
begin
  AbortTransfer := False;
  if AWorkCountMax > 0 then
    ProgressBar1.Max := AWorkCountMax else
    ProgressBar1.Max := BytesToTransfer;
end;
procedure TForm1.IdHTTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
begin
  ProgressBar1.Position := 0;
end;
procedure TForm1.IdHTTP1Status(ASender: TObject; const AStatus: TIdStatus;
  const AStatusText: string);
begin
  ListBox1.ItemIndex := ListBox1.Items.Add(AStatusText);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
  Close;
end;
end.