bt_ddftp.pas

FTP example program

unit bt_ddftp;

interface
uses
  Windows, Messages, SysUtils, Classes, Controls, Forms,
  Dialogs, StdCtrls, Extctrls, ComCtrls, wininet, ShellApi;

type
TBTDragDropFTP = class(TPanel)
private
    hConnect: HInternet;
    FActive: boolean;
    FHostName: string;
    FLabel: TLabel;
    FLogin: string;
    FPassword: string;
    FRemoteDir: string;
    FSaveDialog: TSaveDialog;
    FOnChange: TNotifyEvent;
    FOnDblClick: TNotifyEvent;

    procedure AddFile(lpFindFileData: TWin32FindData);
    procedure Change; dynamic;
    procedure DoDblClick(sender: TObject);
    procedure Loaded; override;
    procedure SetActive(Value: boolean);
    procedure Log(const Text: string);
    procedure WMDropFiles(var msg: TMessage); message WM_DROPFILES;

  public
    ListView: TListView;
    constructor Create(AOwner: TComponent); override;
    procedure Connect;
    procedure RefreshFileList;

  published
    property RemoteDir: string read FRemoteDir write FRemoteDir;
    property Active: boolean read FActive write SetActive;
    property HostName: string read FHostName write FHostName;
    property LoginName: string read FLogin write FLogin;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
    property Password: string read FPassword write FPassword;
    property SaveDialog: TSaveDialog read FSaveDialog write FSaveDialog;
    property StatusLabel: TLabel read FLabel write FLabel;
end;

procedure Register;

implementation
constructor TBTDragDropFTP.Create;
begin
    inherited Create(AOwner);
    parent := Owner As TWinControl;
    if csDesigning in ComponentState then
    begin
        Active := true;
        Height := 128;
        Width  := 261;
        BevelOuter := bvNone;
        BevelInner := bvNone;
        Borderwidth := 3;
    end;
    ListView := TListView.Create(self);
    with ListView do
    begin
        parent    := self;
        ReadOnly  := true;
        align     := alClient;
        viewstyle := vsReport;
        with Columns.Add do
        begin
            caption := 'Name';
            width := 150;
        end;
        with Columns.Add do
        begin
            caption := 'Size';
            width := 70;
            Alignment := taRightJustify;
        end;
        with Columns.Add do
        begin
            caption := 'Date';
            width := 100;
        end;
        LargeImages := TImageList.Create(self);
        LargeImages.Height := 32;
        LargeImages.Width  := 32;
        OnDblClick := DoDblClick;
    end;
end;

procedure TBTDragDropFTP.Connect;
var
hSession: HInternet;
begin
if assigned(hConnect) then InternetCloseHandle(hConnect);
if HostName  = '' then raise Exception.Create('HostName must be specified');
if LoginName = '' then raise Exception.Create('LoginName must be specified');
if Password  = '' then raise Exception.Create('Password must be specified');
Log('Connecting to '+Hostname);
hSession := InternetOpen('BetaSoft', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
if Assigned(hSession) then
begin
    hConnect := InternetConnect(
        hSession,
        PChar(Hostname),
        INTERNET_DEFAULT_FTP_PORT,
        PChar(LoginName),
        PChar(Password),
        INTERNET_SERVICE_FTP,
        INTERNET_FLAG_PASSIVE,
        0);
    if Assigned(hConnect) then
    begin
        Log('Connected to '+Hostname);
        if not FtpSetCurrentDirectory(hConnect, PChar(RemoteDir))
            then ShowMessage('Could not change to '+RemoteDir);
        RefreshFileList;
        Exit;  // q&d
    end
end;
ShowMessage('Could not connect to '+HostName);
end;

procedure TBTDragDropFTP.AddFile(lpFindFileData: TWin32FindData);
var
Seconds, Minutes, Hours, Day, Month, Year, dosDate, dosTime: word;
isDirectory: boolean;
begin
Application.ProcessMessages;
with Listview.items.add do
begin
    isDirectory := (lpFindFileData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY)
                    = FILE_ATTRIBUTE_DIRECTORY;
    if isDirectory then
    begin
        caption:=PChar('['+String(lpFindFileData.cFilename)+']');
        subitems.add('');
    end
    else
    begin
        caption:=lpFindFileData.cFilename;
        subitems.add(inttostr(lpFindFileData.nFileSizeLow));
    end;
    FileTimeToDOSDateTime(lpFindFileData.ftLastWriteTime, dosDate, dosTime);
    Day   := dosDate and 31;
    Month := (dosDate and (32+64+128+256)) shr 5;
    Year  := 1980 + (dosDate and (65535-512)) shr 9;

    Seconds := 2 * (dosTime and 31);
    Minutes := (dosTime and (32+64+128+256+512+1024)) shr 5;
    Hours   := (dosTime and (65535-2047)) shr 11;

    SubItems.Add(DateTimeToStr(
                  EncodeDate(Year, Month, Day)+
                  EncodeTime(Hours, Minutes, Seconds, 0)));
end;
end;

procedure TBTDragDropFTP.RefreshFileList;
var
lpFindFileData: TWin32FindData;
hFind: HInternet;
begin
Log('Transferring data...');
ListView.items.clear;
with ListView.items.add do
begin
     Caption := '[..]';
     SubItems.Add('');
     SubItems.Add('');
end;
hFind := FtpFindFirstFile(hConnect, nil, lpFindFileData, 0, 0);
if Assigned(hFind) then
begin
    if GetLastError<>ERROR_NO_MORE_FILES then
    begin
        AddFile(lpFindFileData);
        while InternetFindNextFile(hFind, @lpFindFileData)
            do AddFile(lpFindFileData);
    end;
    InternetCloseHandle(hFind);
end;
Log('Transfer completed');
end;

procedure TBTDragDropFTP.Loaded;
begin
inherited loaded; // clears csLoading in Componentstate
end;

procedure TBTDragDropFTP.Change;
begin
if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TBTDragDropFTP.SetActive(Value: boolean);
begin
If Value<>FActive then
begin
    FActive := Value;
    if not (csDesigning in ComponentState) then
        DragAcceptFiles(Handle, Value);
end;
end;

procedure TBTDragDropFTP.WMDropFiles;
var
FileName: PChar;
i, count,size,Drop: integer;
begin
  FileName := '';
  Application.BringToFront;
  Drop  := msg.WParam;
  count := DragQueryFile(Drop, $FFFFFFFF, '', 0);
  ListView.items.Clear;
  for i:=1 to count do
  begin
      size := DragQueryFile(Drop, i-1, nil, 1);
      GetMem(filename, size+1);
      DragQueryFile(Drop, i-1, FileName, size+1);
      FTPPutFile(hConnect, FileName,
                 PChar(ExtractFileName(String(FileName))), 0, 0 );
  end;
  FreeMem(filename);
  RefreshFileList;
  DragFinish(Drop);
  Change;
end;

procedure TBTDragDropFTP.Log;
begin
if Assigned(StatusLabel) then
begin
    StatusLabel.Caption := Text;
    Application.ProcessMessages;
end;
end;

procedure TBTDragDropFTP.DoDblClick;
var
TheFile, Folder: string;
begin
if (ListView.Selected<>nil) then
begin
    TheFile := ListView.Selected.Caption;
    if ListView.Selected.SubItems[0]<>'' then
    begin
        if Assigned(SaveDialog) then
        with SaveDialog do
        begin
             FileName := TheFile;
             if Execute then
                 FTPGetFile(hConnect,
                            PChar(TheFile),
                            PChar(FileName),
                            false, 0, 0, 0);
        end;
    end
    else
    begin
        Folder := Copy(TheFile,2,Length(TheFile)-2);
        if FtpSetCurrentDirectory(hConnect, PChar(Folder))
        then RefreshFileList
        else ShowMessage('Could not change to directory '+Folder);
    end;
end;
if Assigned(FOnDblClick) then FOnDblClick(Sender)
end;

procedure Register;
begin
RegisterComponents('BetaTools', [TBTDragDropFTP]);
end;

end.