断点续传

断点续传

关注
发信
关注(28)粉丝(399)

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 = ;

implementation

{$R *.dfm}

procedure TForm1.Button2Click(Sender: TObject);

begin

  AbortTransfer := True;

end;

function TForm1.GetProt(aURL: string): Byte;

begin //检测下载的地址是http还是ftp

  Result := ;

  if Pos('http', LowerCase(aURL)) =  then

    Result := ; //http协议

  if Pos('ftp', LowerCase(aURL)) =  then

    Result := ; //ftp协议

end;

function TForm1.GetURLFileName(aURL: string): string;

var

  i: integer;

  s: string;

begin //返回下载地址的文件名

  s := aURL;

  i := Pos('/', s);

  while i <>  do //去掉"/"前面的内容剩下的就是文件名了

  begin

    Delete(s, , 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)) <>  then //去掉ftp头

    Delete(s, , );

  i := Pos('@', s);

  if i <>  then //地址含用户名，也可能含密码

  begin

    tmp := Copy(s, , i - );

    s := copy(s, i+, Length(s));

    j := Pos(':', tmp);

    if j <>  then //包含密码

    begin

      sName := Copy(tmp, , j - ); //得到用户名

      sPass := Copy(tmp, j + , i - j - ); //得到密码

    end else

    begin

      sName := tmp;

      sPass := Inputbox('输入框','请输入登陆ftp密码','');

    end;

  end else //匿名用户

  begin

    sName := 'anonymous';

    sPass := '[email protected]';

  end;

  i := Pos(':', s);

  j := Pos('/', s);

  sHost := Copy(s, , j - ); //主机

  if i <>  then //含端口

    sPort := Copy(s, i + , j - i - ) else

    sPort := ''; //默认21端口

  tmp := Copy(s, j + , Length(s));

  while j <>  do

  begin

    Delete(s, , j);

    j := Pos('/', s);

  end; //目录

  sDir := '/' + Copy(tmp, , Length(tmp) - Length(s) - );

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 - ;

    tStream.Position := tStream.Size - ; //移动到最后继续下载

    IdHTTP1.Head(aURL);

    IdHTTP1.Request.ContentRangeEnd := IdHTTP1.Response.ContentLength;

  end else //覆盖或新建方式

  begin

    IdHTTP1.Request.ContentRangeStart := ;

  end;

  try

    IdHTTP1.Get(aURL, tStream); //开始下载

  finally

    tStream.Free;

  end;

end;

procedure TForm1.MyDownLoad(aURL, aFile: string; bResume: Boolean);

begin

  case GetProt(aURL) of

    : ShowMessage('不可识别的地址！');

    : HttpDownLoad(aURL, aFile, bResume);

    : 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, ) 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 >  then

    ProgressBar1.Max := AWorkCountMax else

    ProgressBar1.Max := BytesToTransfer;

end;

procedure TForm1.IdHTTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);

begin

  ProgressBar1.Position := ;

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系列组件，使用方法大同小异，下面来看运行效果图：

Delphi完成的断点续传例子 转-LMLPHP

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 := '[email protected]';

  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.
05-02 22:40
Powered by LMLPHP ©2024 断点续传 0.082869