unit KolSimpleftp;
//
// purpose: KOL Ftp component using wininet api
//  author: © 2005, Thaddy de Koning
// Remarks: Based on an example by Charly Calvert
//          
interface

uses
  Windows,
  Kol,
  WinINet;

type
  PFtp = ^TFtp;
  TFtp = object(Tobj)
  private
    FContext: Integer;
    FINet: HInternet;
    FFtpHandle: HInternet;
    FCurFiles: PStrList;
    FServer: string;
    FOnNewDir: TOnEvent;
    FCurDir: string;
    FUserID: string;
    FPassword: string;
    FConnected: Boolean;
    Fport: Dword;
    FAnonymous: boolean;
    function GetCurrentDirectory: string;
    procedure SetUpNewDir;
    procedure setconnected(const Value: Boolean);
  protected
    destructor Destroy; virtual;
    function  Connect: Boolean;
    procedure Disconnect;
  public
    function FindFiles(const mask:string): PStrlist;
    function ChangeDirExact(S: string): Boolean;
    function ChangeDirCustom(S: string): Boolean;
    function BackOneDir: Boolean;
    function GetFile(FTPFile, NewFile: string): Boolean;
    function SendFile1(FTPFile, NewFile: string): Boolean;
    function SendFile2(FTPFile, NewFile: string): Boolean;
    function CustomToFileName(S: string): string;
    property CurFiles: PStrlist read FCurFiles;
    property CurDir: string read FCurDir;
    property UserID: string read FUserID write FUserID;
    property Password: string read FPassword write FPassword;
    property Server: string read FServer write FServer;
    property OnNewDir: TOnEvent read FOnNewDir
                write FOnNewDir;
    property Connected:Boolean read FConnected write setconnected;
    property Port:Dword read Fport write Fport;
    property Files:PStrlist read FCurFiles;
    property Anonymous:boolean read FAnonymous write FAnonymous;
  end;


function NewFtp(AOwner:PControl):PFtp;

implementation


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



function NewFtp(AOwner:PControl):PFtp;
begin
  New(Result,Create);
  AOwner.add2autofree(Result);
  Result.FCurFiles := NewStrlist;
  Result.FINet := InternetOpen('WinINet1', 0, nil, 0, 0);
  Result.Fport:=0;//default port 21
end;

destructor TFtp.Destroy;
begin
  if FINet <> nil then
    InternetCloseHandle(FINet);
  if FFtpHandle <> nil then
    InternetCloseHandle(FFtpHandle);
  FCurfiles.Free;
  inherited Destroy;
end;

function TFtp.Connect: Boolean;
begin
  FContext := 255;
  if Fanonymous then
    FftpHandle := InternetConnect(FINet, PChar(FServer), Fport,
     nil, nil, Internet_Service_Ftp, 0, FContext)
  else
    FftpHandle := InternetConnect(FINet, PChar(FServer), Fport,
     PChar(FUserID), PChar(FPassWord), Internet_Service_Ftp, 0, FContext);
  if FFtpHandle = nil then
  begin
    Result := False;
    Messagebox(0,'Connection failed','Error',MB_ICONERROR or MB_OK);
  end
  else begin
    SetUpNewDir;
    Result := True;
  end;
end;

function TFtp.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 TFtp.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 := Int2Str(FindData.dwFileAttributes);
  end;
  S := S + GetDots(75);
  Move(FindData.CFilename[0], S[6], StrLen(FindData.CFileName));
  Temp := Int2Str(FindData.nFileSizeLow);
  Move(Temp[1], S[25], Length(Temp));
  Result := S;
end;

function TFtp.FindFiles(const mask:string): PStrlist;
var
  FindData: TWin32FindData;
  FindHandle: HInternet;
begin
   FindHandle := FtpFindFirstFile(FFtphandle,Pchar(Mask),
     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;
   FCurFiles.Sort(false);
   Result := FCurFiles;
end;

function TFtp.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 TFtp.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 TFtp.ChangeDirExact(S: string): Boolean;
begin
  if S <> '' then
    FtpSetCurrentDirectory(FFTPHandle, PChar(S));
  Result := True;
  Fcurfiles.Clear;
  FindFiles('*.*');
  SetUpNewDir;
end;

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

function TFtp.GetFile(FTPFile, NewFile: string): Boolean;
begin
  Result := FtpGetFile(FFTPHandle, PChar(FTPFile), PChar(NewFile),
               False, File_Attribute_Normal,
               Ftp_Transfer_Type_Binary, 0);
end;

function TFtp.SendFile1(FTPFile, NewFile: string): Boolean;
const
  Size:DWord = 3000;
var
  Transfer: Bool;
  Error: DWord;
  S: string;
begin
  Transfer := FtpPutFile(FFTPHandle, PChar(FTPFile), 
                         PChar(NewFile),
                         Ftp_Transfer_Type_Binary, 0);

  if not Transfer then begin
    Error := GetLastError;
    Messagebox(0, PChar(Format('Error Number: %d. Hex: %x',[error,error])),'Error',MB_ICONERROR or MB_OK);
    SetLength(S, Size);
    if not InternetGetLastResponseInfo(Error, PChar(S), Size) then
    begin
      Error := GetLastError;
      Messagebox(0, PChar(Format('Error Number: %d. Hex: %x',[error,error])),'Error',MB_ICONERROR or MB_OK);
    end;
    Messagebox(0, PChar(Format('Error Number: %d. Hex: %x',[error,error])),'Error',MB_ICONERROR or MB_OK);

  end else
    Messagebox(0, 'Success','Information',MB_ICONINFORMATION or MB_OK);
  Result := Transfer;
end;

function TFtp.SendFile2(FTPFile, NewFile: string): Boolean;
var
  FHandle: HInternet;
begin
  FHandle :=  FtpOpenFile(FFTPHandle, 'sam.txt', GENERIC_READ,
                           FTP_TRANSFER_TYPE_BINARY, 0);
  if FHandle <> nil then
  InternetCloseHandle(FHandle)
  else
    Messagebox(0, 'Send file failed','Error',MB_ICONERROR or MB_OK);
  Result := True;
end;

procedure TFtp.Disconnect;
begin
  if FFtpHandle <> nil then
  begin
   InternetCloseHandle(FFtpHandle);
   FFtpHandle:=nil;
  end;
end;

procedure TFtp.setconnected(const Value: Boolean);
begin
  if Value = True then Fconnected:=Connect else
  begin
    Disconnect;
    FConnected:= Value;
  end;
end;

end.