winapiftp.pas

纯WINDOWS API的FTP上传和下载控件。

unit WinAPIFtp;
{
  基于Windows API实现的FTP上传下载功能（不支持断点续传）
}
interface

uses
  Windows,Classes,WinINet,SysUtils,comctrls;

type
  TMiniFtp = class(TComponent)
  private
    FContext: Integer;
    FINet: HInternet;
    FFtpHandle: HInternet;     //
    FFtpConn:HINTERNET;        //
    FCurFiles: TStringList;
    FHostName:string;
    FPort:string;
    FOnNewDir: TNotifyEvent;
    FCurDir: string;
    FUserName: string;
    FPassword: string;
    FLastMsg:string;

    currfileName:string;   //正在传输的文件名
    STime:tdatetime;
    LastError:string;
    LastErrorCode:integer;
    ID:integer;
    Uploading:boolean;      //正在上传
    AverageSpeed: Double;


    AbortTransfer: Boolean;
    TransferrignData: Boolean;
    BytesToTransfer:integer;

    loFtpSock:HINTERNET;
    loFtpConn:HINTERNET;
    FAbort:boolean;

    function GetCurrentDirectory: string;
    procedure SetUpNewDir;

    function getConnect: boolean;
    procedure setConnect(const Value: boolean);
  protected
    destructor Destroy; override;
    procedure checkError;
  public
    LocalFileName:string;
    HostFileName:string;
    FileSize:int64;
    LastAccessTime:TDateTime;

    onProgress:procedure(Sender:Tobject;Count:LongInt;var Abort:boolean) of object;
   //onWork:procedure(Sender: TObject;Count:LongInt;var Abort : Boolean) of object;
    constructor Create(AOwner: TComponent); override;

    function Connect: Boolean;
    procedure Disconnect;

    function FindFiles: TStringList;
    function FileInfo(APath,AFileName: string):boolean;

    function ChangeDirExact(S: string): Boolean;
    function ChangeDirCustom(S: string): Boolean;
    function BackOneDir: Boolean;
    function CustomToFileName(S: string): string;

    function get(AFtpFile,ALocFile:string):boolean;
    function put(ALocFile,AFtpFile:string):boolean;

    procedure Quit;
  published
    property CurFiles: TStringList read FCurFiles;
    property CurDir: string read FCurDir;
    property UserName: string read FUserName write FUserName;
    property Password: string read FPassword write FPassword;
    property HostName: string read FHostName write FHostName;
    property OnNewDir: TNotifyEvent read FOnNewDir write FOnNewDir;
    property connected:boolean read getConnect write setConnect;
    property Port:string read FPort write FPort;
  end;

procedure Register;

var
  ftpRunning:boolean;
implementation

uses
  Dialogs;
var
  ftpBuffersize:integer=32000;

// A few utility functions

function GetFirstToken(S: string; Token: Char): string;
var
  Temp: string;
  Index: INteger;
begin
  Index := Pos(Token, S);
  if Index < 1 then begin
    GetFirstToken := '';
    Exit;
  end;
  Dec(Index);
  SetLength(Temp, Index);
  Move(S[1], Temp[1], Index);
  GetFirstToken := Temp;
end;

function StripFirstToken(S: string; Ch: Char): string;
var
  i, Size: Integer;
begin
  i := Pos(Ch, S);
  if i = 0 then begin
    StripFirstToken := S;
    Exit;
  end;
  Size := (Length(S) - i);
  Move(S[i + 1], S[1], Size);
  SetLength(S, Size);
  StripFirstToken := S;
end;

function ReverseStr(S: string): string;
var
  Len: Integer;
  Temp: String;
  i,j: Integer;
begin
  Len := Length(S);
  SetLength(Temp, Len);
  j := Len;
  for i := 1 to Len do begin
    Temp[i] := S[j];
    dec(j);
  end;
  ReverseStr := Temp;
end;

function StripLastToken(S: string; Token: Char): string;
var
  Temp: string;
  Index: INteger;
begin
  SetLength(Temp, Length(S));
  S := ReverseStr(S);
  Index := Pos(Token, S);
  Inc(Index);
  Move(S[Index], Temp[1], Length(S) - (Index - 1));
  SetLength(Temp, Length(S) - (Index - 1));
  StripLastToken := ReverseStr(Temp);
end;


procedure Register;
begin
  RegisterComponents('DdlVcl', [TMiniFtp]);
end;

constructor TMiniFtp.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCurFiles := TStringList.Create;
  FINet := InternetOpen('WinINet1', 0, nil, 0, 0);
end;

destructor TMiniFtp.Destroy;
begin
  Disconnect();
  inherited Destroy;
end;

function TMiniFtp.Connect: Boolean;
begin
  loFtpSock:=internetopen(Pchar('application'),internet_open_type_direct,nil,nil,internet_flag_no_cache_write);
  if (loFtpSock <> nil ) then
     loFtpConn:=internetconnect(loFtpSock,Pchar(FHostName),21,pchar(FUserName),pchar(FPassWord),internet_service_ftp,internet_flag_existing_connect or internet_flag_passive,$0);

  exit;
  FContext := 255;
  FftpHandle := InternetConnect(FINet, PChar(FHostName), 0,PChar(FUserName), PChar(FPassWord),Internet_Service_Ftp, 0, FContext);
  if FFtpHandle = nil then
    Result := False
  else begin
    if FFtpConn<>nil then
    begin
      SetUpNewDir;
      Result := True;
    end;
  end;
end;

function TMiniFtp.GetCurrentDirectory: string;
var
  Len: Cardinal;
  S: string;
begin
  Len := 0;
  ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);
  SetLength(S, Len);
  ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);
  Result := S;
end;

procedure TMiniFtp.SetUpNewDir;
begin
  FCurDir := GetCurrentDirectory;
  if Assigned(FOnNewDir) then
    FOnNewDir(Self);             
end;

function GetDots(NumDots: Integer): string;
var
  S: string;
  i: Integer;
begin
  S := '';
  for i := 1 to NumDots do
    S := S + ' ';
  Result := S;
end;

function GetFindDataStr(FindData: TWin32FindData): string;
var
  S: string;
  Temp: string;
begin
  case FindData.dwFileAttributes of
    FILE_ATTRIBUTE_ARCHIVE: S := 'A';
//  FILE_ATTRIBUTE_COMPRESSED: S := 'C';
    FILE_ATTRIBUTE_DIRECTORY: S := 'D';
    FILE_ATTRIBUTE_HIDDEN: S := 'H';
    FILE_ATTRIBUTE_NORMAL: S := 'N';
    FILE_ATTRIBUTE_READONLY: S := 'R';
    FILE_ATTRIBUTE_SYSTEM: S := 'S';
    FILE_ATTRIBUTE_TEMPORARY: S := 'T';
  else
    S := IntToStr(FindData.dwFileAttributes);
  end;
  S := S + GetDots(75);
  Move(FindData.CFilename[0], S[6], StrLen(FindData.CFileName));
  Temp := IntToStr(FindData.nFileSizeLow);
  Move(Temp[1], S[25], Length(Temp));
  Result := S;
end;

function TMiniFtp.FindFiles: TStringList;
var
  FindData: TWin32FindData;
  FindHandle: HInternet;
begin
   FindHandle := FtpFindFirstFile(FFtphandle, '*.*',
     FindData, 0, 0);
   if FindHandle = nil then begin
     Result := nil;
     Exit;
   end;
   FCurFiles.Clear;
   FCurFiles.Add(GetFindDataStr(FindData));
   while InternetFindnextFile(FindHandle, @FindData) do
     FCurFiles.Add(GetFindDataStr(FindData));
   InternetCloseHandle(Findhandle);
   GetCurrentDirectory;
   Result := FCurFiles;
end;

function TMiniFtp.CustomToFileName(S: string): string;
const
  PreSize = 6;
var
  Temp: string;
  TempSize: Integer;
begin
  Temp := '';
  TempSize := Length(S) - PreSize; 
  SetLength(Temp, TempSize);
  Move(S[PreSize], Temp[1], TempSize);
  Temp := GetFirstToken(Temp, ' ');
  Result := Temp;
end;

function TMiniFtp.BackOneDir: Boolean;
var
  S: string;
begin
  S := FCurDir;
  S := StripLastToken(S, '/');
  if S = '/' then begin
    Result := False;
    Exit;
  end;

  if S <> '' then begin
    ChangeDirExact(S);
    Result := True;
  end else begin
    ChangeDirExact('/');
    Result := True;
  end;
end;

// Changes to specific directory in S
function TMiniFtp.ChangeDirExact(S: string): Boolean;
begin
  if S <> '' then
    FtpSetCurrentDirectory(FFTPHandle, PChar(S));
  Result := True;
  FindFiles;
  SetUpNewDir;
end;

// Assumes S has been returned by GetFindDataString;
function TMiniFtp.ChangeDirCustom(S: string): Boolean;
begin
  S := CustomToFileName(S);
  if S <> '' then
    FtpSetCurrentDirectory(FFTPHandle, PChar(S));
  Result := True;
  FindFiles;
  SetUpNewDir;
end;

function TMiniFtp.get(AFtpFile, ALocFile: string): boolean;
var
  buffer:pointer;
  loFtpFileHandle:pointer;
  liReadedSize:cardinal;
  loFileStream:tfilestream;
begin
  result:=false;
  BytesToTransfer:=0;
  LastErrorCode:=0;

  if (loFtpSock<>nil)and(loFtpConn<> nil) then
  begin
    loFtpFileHandle:=ftpopenfile(loFtpConn, pchar(aftpFile),generic_read,FTP_TRANSFER_TYPE_BINARY,0);
    if loFtpFileHandle<> nil then
    begin
      getmem(buffer,ftpBuffersize);
      //建立空文件
      loFileStream:=tfilestream.Create(ALocFile,fmCreate);
      loFileStream.Free;

      //以共享写方式打开文件
      loFileStream:=tfilestream.Create(ALocFile,fmOpenWrite or fmShareDenyNone);
      try
        try
          repeat
            if not ftpRunning then exit;
            internetreadfile(loFtpFileHandle,buffer,ftpBuffersize,liReadedSize);
            if liReadedSize=0 then
            begin
              break;
            end;
            if not ftpRunning then exit;
            inc(BytesToTransfer,liReadedSize);
            loFileStream.Position :=loFileStream.Size;
            loFileStream.Write(buffer^,liReadedSize);
            if Assigned(onProgress) then
              onProgress(self,BytesToTransfer,FAbort);
          until liReadedSize<ftpBuffersize;
          if LastErrorCode=0 then
          begin
            result:=true;
            FLastMsg:='Success';
          end;
        except
        end;
      finally
        InternetCloseHandle(loFtpFileHandle);
        loFileStream.free;
        FreeMem(buffer,ftpBuffersize);
      end;
    end
    else
      checkError();
  end;
end;

function TMiniFtp.put(ALocFile,AFtpFile: string): boolean;
var
  buffer:pointer;
  loFtpFileHandle:pointer;
  liReadedSize:cardinal;
  loFileStream:tfilestream;
begin
  BytesToTransfer:=0;
  result:=false;
  if (loFtpSock<>nil)and(loFtpConn<> nil) then
  begin
    loFtpFileHandle:=ftpopenfile(loFtpConn, pchar(aftpFile),GENERIC_WRITE,FTP_TRANSFER_TYPE_BINARY,0);
    if loFtpFileHandle<> nil then
    begin
      getmem(buffer,ftpBuffersize);
      //以共享写方式打开文件
      loFileStream:=tfilestream.Create(ALocFile,fmOpenRead or fmShareDenyNone);
      try
        repeat
          if not ftpRunning then exit;

          //loFileStream.Position :=loFileStream.Size;
          liReadedSize:=loFileStream.Read(buffer^,ftpBuffersize);
          //读取结束了
          if BytesToTransfer+liReadedSize>=loFileStream.Size then
          begin
            liReadedSize:=loFileStream.Size-BytesToTransfer;
            result:=true;
          end;
          //loFileStream.Position :=loFileStream.Position+liReadedSize;
          if not ftpRunning then exit;

          InternetWriteFile(loFtpFileHandle,buffer,ftpBuffersize,liReadedSize);
          inc(BytesToTransfer,liReadedSize);

          if not ftpRunning then exit;

          if Assigned(onProgress) then
            onProgress(self,BytesToTransfer,fabort);
        until BytesToTransfer>=loFileStream.Size;
      finally
        InternetCloseHandle(loFtpFileHandle);
        loFileStream.free;
        FreeMem(buffer,ftpBuffersize);
      end;
    end;
  end;
end;

function TMiniFtp.getConnect: boolean;
begin
  result:=(loFtpSock<>nil) and(loFtpConn<>nil);
end;

procedure TMiniFtp.setConnect(const Value: boolean);
begin
  if Value then
    Connect
  else
    Disconnect;
end;

procedure TMiniFtp.Disconnect;
begin
  if loFtpConn<>nil then
  begin
    InternetCloseHandle(loFtpConn);
    loFtpConn:=nil;
  end;
  if loFtpSock<>nil then
  begin
    InternetCloseHandle(loFtpSock);
    loFtpSock:=nil;
  end;
end;

procedure TMiniFtp.checkError;
var
  buffer:pointer;
  loFtpFileHandle:pointer;
  liReadedSize:cardinal;
  loFileStream:tfilestream;
  error,size:Cardinal;
  s:string;
begin
  LastErrorCode:=0;
  size:=3000;
  Error := GetLastError;
  FLastMsg:=Format('Error Number: %d. Hex: %x',[Error, Error]);
  SetLength(S, Size);
  if not InternetGetLastResponseInfo(Error, PChar(S), Size) then
  begin
    Error := GetLastError;
    FLastMsg:=Format('Error Number: %d. Hex: %x', [Error, Error]);
    LastErrorCode:=error;
  end;
  FLastMsg:=Format('Error Number: %d. Hex: %x Info: %s', [Error, Error, S]);
end;

procedure TMiniFtp.Quit;
begin
  Disconnect;
end;


function TMiniFtp.FileInfo(APath,AFileName: string):boolean;
var
  FindHandle: HInternet;
  loFileInfo:TWin32FindData;
  LocalFileTime: TFileTime;
  SystemTime:TSystemTime;
  s:string;
  FindResult:boolean;
begin
   FtpSetCurrentDirectory(loFtpConn,pchar(APath));
   FindHandle := FtpFindFirstFile(loFtpConn, pchar(AFileName),loFileInfo, INTERNET_FLAG_RELOAD,0);
   if FindHandle = nil then
     Result := false
   else
   begin
     s:=loFileInfo.cFileName;
     if s='' then;

     FindResult:=true;
     while FindResult do
     begin
       s:=loFileInfo.cFileName;
       if s='' then;
       if (s<>'.') and (s<>'..')and(s=AFileName) then
       begin
         FileSize :=(loFileInfo.nFileSizeHigh*MAXWORD)+ loFileInfo.nFileSizeLow;
         FileTimeToLocalFileTime(loFileInfo.ftLastWriteTime,LocalFileTime);
         if FileTimeToSystemTime(LocalFileTime,SystemTime) then
           LastAccessTime :=SystemTimeToDateTime(SystemTime);
         result:= true;
       end;
       FindResult:=InternetFindNextFile(FindHandle, @loFileInfo);
     end;
   end;
   InternetCloseHandle(Findhandle);
end;

end.