• 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.
  • 相关阅读:
    一种新的数据类型Symbol
    var/let/const的区别
    Vue-cli脚手架 安装 并创建项目--命令
    命令
    git版本控制入门--码云
    闲鱼hu超赞,有赞必回,24小时在线!咸鱼互赞超赞留言评
    咸鱼互粉互赞必回 有没有宝贝要的_咸鱼吧
    闲鱼互赞群
    拍摄者能在抖音教学中学会什么
    影响抖音推荐机制的因素和上热门
  • 原文地址:https://www.cnblogs.com/zhangzhifeng/p/6141557.html
Copyright © 2020-2023  润新知