downfile.pas

提取网页文件图片地址,应用此工具

{*******************************************************}
{                                                       }
{       xujin Delphi Visual Component Library           }
{                                                       }
{      组件名称　：Tdownfile                            }
{　　　　　作用:　通过ＨＴＴＰ方式和ＦＴＰ方式下载需要的}
{                  文件　　　　　                       }
{　　　　                                               }
{                                                       }
{                                                       }
{                                                       }
{  下载元件　　　开始编写时间：２００５－10－１　　　　 }
{                                                       }
{*******************************************************}


unit downfile;

interface
  uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls,
   StdCtrls,dialogs, ComCtrls, IdFTP, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdHTTP, IdHTTPHeaderInfo, ExtCtrls;

  type
   TdownFile = Class(Tcomponent)
    private
        FidFTP : TidFTP;
        FidHTTP : TidHTTP;
        procedure MyDownLoad(aURL, aFile,destfile: string; bResume: Boolean);
        function GetProt(aURL: string): Byte;
        function GetURLFileName(aURL: string): string;
        procedure GetFTPParams(aURL: string; var sName, sPass, sHost, sPort,
                 sDir: string);
      // FAbortTransfer: Boolean; //是否中断
     //  FBytesToTransfer: integer; //下载总大小
    public
      procedure FtpDownLoad(aURL, aFile,destfile: string; bResume: Boolean);
      procedure HttpDownLoad(aURL, aFile,destfile: string; bResume: Boolean);
      function FtpFileExists(aURL:string):boolean;//判断在一个目录下是否存在文件，为阅卷系统而写
      Constructor create(AOwner:Tcomponent);override;
      destructor Destroy; override;
   end;
procedure Register;
implementation
      Constructor TdownFile.create(AOwner:Tcomponent);
      begin
        FidFTP := TidFTP.Create(nil);
        FidHTTP := TidHTTP.Create(nil);
        inherited;
      end;

       destructor TdownFile.Destroy;
       begin
         FidFTP.free;
         FidHTTP.free;
         inherited;
       end;



    procedure TdownFile.FtpDownLoad(aURL, aFile,destfile: string; bResume: Boolean);
    var
      tStream: TFileStream;
      sName, sPass, sHost, sPort, sDir: string;

      FBytesToTransfer: integer;
   begin //ftp方式下载
   //showmessage(aURL);
     if FileExists(destfile) then //建立文件流
        //    DeleteFile(aFile)
        tStream := TFileStream.Create(destfile, fmOpenWrite) else
        tStream := TFileStream.Create(destfile, fmCreate);
       // showmessage('afile '+afile);
      GetFTPParams(aURL, sName, sPass, sHost, sPort, sDir);
      with FIdFTP do
       try
        if Connected then Disconnect; //重新连接
        Username := 'anonymous';
        Password := '';
        Host := sHost;
        Port := 21;
       Connect;
      except
       exit;
      end;

  FIdFTP.ChangeDir(sDir); //改变目录
  FBytesToTransfer := FIdFTP.Size(aFile);
  try
    if bResume then //续传
    begin
      tStream.Position := tStream.Size;
      FIdFTP.Get(afile, tStream, True);

    end else
    begin
      FIdFTP.Get(afile, tStream, False);

    end;
  finally
    tStream.Free;
  end;
end;

procedure TdownFile.HttpDownLoad(aURL, aFile,destfile: 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
    FIdHTTP.Request.ContentRangeStart := tStream.Size - 1;
    tStream.Position := tStream.Size - 1; //移动到最后继续下载
    FIdHTTP.Head(aURL);
    FIdHTTP.Request.ContentRangeEnd := FIdHTTP.Response.ContentLength;
  end else //覆盖或新建方式
  begin
    FIdHTTP.Request.ContentRangeStart := 0;
  end;

  try
    FIdHTTP.Get(aURL, tStream); //开始下载
  finally
    tStream.Free;
  end;
end;


procedure TdownFile.MyDownLoad(aURL, aFile,destfile: string; bResume: Boolean);
begin
  case GetProt(aURL) of
    0: ShowMessage('不可识别的地址！');
    1: HttpDownLoad(aURL, aFile,destfile, bResume);
    2: FtpDownLoad(aURL, aFile,destfile, bResume);
  end;
end;


function TdownFile.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 TdownFile.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;
   showmessage('下载文件名:'+s);
  Result := s;
end;


procedure TdownFile.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 := '[e-mail]';
  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);
 // showmessage('sdir:'+sdir);
end;


function TdownFile.FtpFileExists(aURL: string): boolean;
var
 sName, sPass, sHost, sPort, sDir: string;
 FileList : Tstrings;
begin
  result := true;
  try
   FileList := TstringList.Create;
    with FIdFTP do
       try
        if  not FidFTP.Connected  then  //重新连接
          begin
           Username := 'anonymous';
           Password := '';
           Host := sHost;
           Port := 21;
           Connect;

          end;
      except
       result := false;
       exit;
      end;
   GetFTPParams(aURL, sName, sPass, sHost, sPort, sDir);
  // showmessage(sdir);
   FIdFTP.ChangeDir(sDir); //改变目录

  except             //目录不存在
  // showmessage('目录不存在！');
   result := false;
   exit;
  end;
  try
     FIdFTP.List(FileList,'',false);
  except
   //  showmessage('文件不存在！');
      FileList.free;
      result := false;
      exit;
   end;
     result := (FileList.Count > 0);
     FileList.free;
end;


procedure Register;
begin
  RegisterComponents('XJVCL', [TdownFile]);
end;
end.