main.pas

Drag files and Drop to delphi forms 0402

unit main;

interface

uses
  RingbufferStream,
  DragDrop, DropSource, DragDropFormats,
  Messages, Dialogs,
  ActiveX, Windows, Classes, Controls, Forms, StdCtrls, ComCtrls, ExtCtrls,
  Buttons, ImgList, ToolWin, ActnList, IdAntiFreezeBase, IdAntiFreeze,
  IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  IdExplicitTLSClientServerBase, IdFTP;

const
  MSG_PROGRESS = WM_USER;
  MSG_STATUS = WM_USER+1;
  MSG_TRANSFER = WM_USER+2;
  MSG_BROWSE = WM_USER+3;

type
  TDragDropStage = (dsNone, dsIdle, dsDrag, dsDragAsync, dsDragAsyncFailed, dsDrop, dsGetData, dsGetStream, dsDropComplete);

  TBrowseOption = (boBrowse, boUpdateCombo);
  TBrowseOptions = set of TBrowseOption;

  TFormMain = class(TForm)
    DropEmptySource1: TDropEmptySource;
    DataFormatAdapterSource: TDataFormatAdapter;
    ProgressBar1: TProgressBar;
    StatusBar1: TStatusBar;
    ListViewFiles: TListView;
    CoolBar1: TCoolBar;
    ToolBarMain: TToolBar;
    AnimateThrobber: TAnimate;
    ComboAddress: TComboBox;
    ButtonBack: TToolButton;
    ButtonForward: TToolButton;
    ButtonReload: TToolButton;
    ButtonStop: TToolButton;
    ImageListNormal: TImageList;
    ButtonUp: TToolButton;
    ToolButton1: TToolButton;
    ImageListDisabled: TImageList;
    ImageListHot: TImageList;
    ButtonHome: TToolButton;
    ToolButton2: TToolButton;
    ToolButton3: TToolButton;
    ActionList1: TActionList;
    ActionBack: TAction;
    ActionForward: TAction;
    ActionRefresh: TAction;
    ActionStop: TAction;
    ActionUp: TAction;
    ActionHome: TAction;
    IdFTP1: TIdFTP;
    IdAntiFreeze1: TIdAntiFreeze;
    ImageListExplorer: TImageList;
    Timer1: TTimer;
    procedure DropEmptySource1Drop(Sender: TObject; DragType: TDragType;
      var ContinueDrop: Boolean);
    procedure DropEmptySource1AfterDrop(Sender: TObject;
      DragResult: TDragResult; Optimized: Boolean);
    procedure DropEmptySource1GetData(Sender: TObject;
      const FormatEtc: tagFORMATETC; out Medium: tagSTGMEDIUM;
      var Handled: Boolean);
    procedure OnMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
    procedure ComboAddressKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormDestroy(Sender: TObject);
    procedure ActionBackExecute(Sender: TObject);
    procedure ActionForwardExecute(Sender: TObject);
    procedure ActionRefreshExecute(Sender: TObject);
    procedure ActionStopExecute(Sender: TObject);
    procedure ActionUpExecute(Sender: TObject);
    procedure ActionHomeExecute(Sender: TObject);
    procedure ActionBackUpdate(Sender: TObject);
    procedure ActionForwardUpdate(Sender: TObject);
    procedure ActionRefreshUpdate(Sender: TObject);
    procedure ActionStopUpdate(Sender: TObject);
    procedure ActionUpUpdate(Sender: TObject);
    procedure ComboAddressCloseUp(Sender: TObject);
    procedure ListViewFilesDblClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure IdFTP1Work(Sender: TObject; AWorkMode: TWorkMode;
      const AWorkCount: Integer);
    procedure IdFTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
      const AWorkCountMax: Integer);
    procedure IdFTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
    procedure ActionHomeUpdate(Sender: TObject);
  private
    function GetTransferInProgress: boolean;
  private
    FHistoryList: TStringList;
    FHistoryIndex: Integer;
    FTempPath: string;
    FAddress: string;

    FStatus: TDragDropStage;
    FAbort: boolean;
    FAborted: boolean;
    FWriteStream: TFifoStream;
    FTransferCount: integer;
    FBusyCount: integer;
    FCurrentFileSize: int64;
    function GetBusy: boolean;
    procedure SetStatus(const Value: TDragDropStage);
    procedure SetProgress(Count, MaxCount: integer);
    procedure OnGetStream(Sender: TFileContentsStreamOnDemandClipboardFormat;
      Index: integer; out AStream: IStream);

    procedure MsgProgress(var Message: TMessage); message MSG_PROGRESS;
    procedure MsgStatus(var Message: TMessage); message MSG_STATUS;
    procedure MsgTransfer(var Message: TMessage); message MSG_TRANSFER;
    procedure MsgBrowse(var Message: TMessage); message MSG_BROWSE;

    procedure Browse(const Address: string; Options: TBrowseOptions = [boBrowse]);
    procedure AddSourceFile(const Filename: string);
    procedure BeginBusy;
    procedure EndBusy;
    procedure BeginTransfer;
    procedure EndTransfer;
    property Status: TDragDropStage read FStatus write SetStatus;
    property Busy: boolean read GetBusy;
    property TransferInProgress: boolean read GetTransferInProgress;
  protected
  public
  end;

var
  FormMain: TFormMain;

implementation

{$R *.DFM}
{$R Throbber.res}

uses
  IdURI,
  IdFTPList,
  IdAllFTPListParsers,
  ShlObj,
  ShellApi,
  Graphics,
  SysUtils, StrUtils;

const
  sAddressHome = 'ftp://gatekeeper.dec.com/';

type
  TBrowseKind = (bkAddress, bkUp, bkRefresh);

function AddTrailingSlash(const s: string): string;
begin
  Result := s;
  if (RightStr(Result, 1) <> '/') then
    Result := Result+'/';
end;

function SizeToStr(Value: Int64): string;
var
  Postfix: string;
begin
  if (Value > 1024) then
  begin
    Value := Value div 1024;
    Postfix := ' Kb';
  end else
    Postfix := '';
  Result := Format('%.0n%s', [Int(Integer(Value)), Postfix]);
end;

function DateTimeToFileTime(ADate: TDateTime): TFileTime;
var
  tmp: integer;
  LocalFileTime: TFileTime;
begin
  tmp := DateTimeToFileDate(ADate);
  DosDateTimeToFileTime(LongRec(tmp).Hi, LongRec(tmp).Lo, LocalFileTime);
  LocalFileTimeToFileTime(LocalFileTime, Result);
end;

procedure TFormMain.FormCreate(Sender: TObject);
var
  SHFileInfo: TSHFileInfo;
begin
  FHistoryList := TStringList.Create;
  FHistoryIndex := -1;

  // Setup event handler to let a drop target request data from our drop source.
  (DataFormatAdapterSource.DataFormat as TVirtualFileStreamDataFormat).OnGetStream := OnGetStream;

  StatusBar1.ControlStyle := StatusBar1.ControlStyle +[csAcceptsControls];
  Status := dsIdle;

  ImageListExplorer.Handle := SHGetFileInfo('', 0, SHFileInfo, SizeOf(TSHFileInfo),
    SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
  ImageListExplorer.ShareImages := True;
  ImageListExplorer.BlendColor := clHighlight;
  ImageListExplorer.DrawingStyle := dsTransparent;

  SetLength(FTempPath, MAX_PATH);
  SetLength(FTempPath, GetTempPath(Length(FTempPath), PChar(FTempPath)));

  AnimateThrobber.ResName := 'AVI_THROBBER';
end;

procedure TFormMain.FormDestroy(Sender: TObject);
begin
  FHistoryList.Free;
end;

procedure TFormMain.AddSourceFile(const Filename: string);
var
  ModifiedDate: TDateTime;
  FileSize: int64;
  i: integer;
begin
  FileSize := IdFTP1.Size(Filename);
  ModifiedDate := 0;

  for i := 0 to IdFTP1.DirectoryListing.Count-1 do
    if (IdFTP1.DirectoryListing[i].FileName = Filename) then
    begin
      ModifiedDate := IdFTP1.DirectoryListing[i].ModifiedDate;
      if (FileSize = -1) then
        FileSize := IdFTP1.DirectoryListing[i].Size;
      break;
    end;

  if (FileSize = -1) then
    exit;

  // Transfer the file name to the data format.
  // The content will be extracted by the target on-demand.
  i := TVirtualFileStreamDataFormat(DataFormatAdapterSource.DataFormat).FileNames.Add(Filename);
  // Set the size and timestamp attributes of the filename we just added.
  with PFileDescriptor(TVirtualFileStreamDataFormat(DataFormatAdapterSource.DataFormat).FileDescriptors[i])^ do
  begin
    if (ModifiedDate <> 0) then
      ftLastWriteTime := DateTimeToFileTime(ModifiedDate)
    else
      GetSystemTimeAsFileTime(ftLastWriteTime);
    nFileSizeLow := FileSize and $00000000FFFFFFFF;
    nFileSizeHigh := (FileSize and $FFFFFFFF00000000) shr 32;
    dwFlags := FD_WRITESTIME or FD_FILESIZE or FD_PROGRESSUI;
  end;
end;

procedure TFormMain.OnMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  i: integer;
  AnyFile: boolean;
begin
  if (ListViewFiles.Selected = nil) or (Busy) then
    exit;

  TVirtualFileStreamDataFormat(DataFormatAdapterSource.DataFormat).FileNames.Clear;

  AnyFile := False;
  for i := 0 to ListViewFiles.Items.Count-1 do
    if (ListViewFiles.Items[i].Selected) and
      (TIdDirItemType(ListViewFiles.Items[i].Data) = ditFile) then
    begin
      AnyFile := True;
      break;
    end;

  if (not AnyFile) then
    exit;

  Status := dsIdle;
  if DragDetectPlus(Handle, Point(X, Y)) then
  begin
    for i := 0 to ListViewFiles.Items.Count-1 do
    begin
      if (ListViewFiles.Items[i].Selected) and
        (TIdDirItemType(ListViewFiles.Items[i].Data) = ditFile) then
        AddSourceFile(ListViewFiles.Items[i].Caption);
    end;

    if (TVirtualFileStreamDataFormat(DataFormatAdapterSource.DataFormat).FileNames.Count = 0) then
      exit;

    Status := dsDrag;

    // Perform an asynchronous drag (in a separate thread).
    if (DropEmptySource1.Execute(True) = drAsync) then
      Status := dsDragAsync
    else
      Status := dsDragAsyncFailed;
  end;
end;

procedure TFormMain.DropEmptySource1Drop(Sender: TObject;
  DragType: TDragType; var ContinueDrop: Boolean);
begin
  // Warning:
  // This event will be called in the context of the transfer thread during an
  // asynchronous transfer. See TFormMain.OnProgress for a comment on this.
  Status := dsDrop;
end;

procedure TFormMain.DropEmptySource1AfterDrop(Sender: TObject;
  DragResult: TDragResult; Optimized: Boolean);
begin
  // Warning:
  // This event will be called in the context of the transfer thread during an
  // asynchronous transfer. See TFormMain.OnProgress for a comment on this.
  Status := dsDropComplete;
end;

procedure TFormMain.DropEmptySource1GetData(Sender: TObject;
  const FormatEtc: tagFORMATETC; out Medium: tagSTGMEDIUM;
  var Handled: Boolean);
begin
  // Warning:
  // This event will be called in the context of the transfer thread during an
  // asynchronous transfer. See TFormMain.OnProgress for a comment on this.
  Status := dsGetData;
end;

type
  TFifoStreamAdapter = class(TFixedStreamAdapter, IStream)
  private
  public
    function Read(pv: Pointer; cb: Longint;
      pcbRead: PLongint): HResult; override; stdcall;
  end;

function TFifoStreamAdapter.Read(pv: Pointer; cb: Integer;
  pcbRead: PLongint): HResult;
begin
  Result := inherited Read(pv, cb, pcbRead);
  if (TFifoStream(Stream).Aborted) then
    Result := E_ABORT;
end;

procedure TFormMain.OnGetStream(Sender: TFileContentsStreamOnDemandClipboardFormat;
  Index: integer; out AStream: IStream);
var
  RingBuffer: TRingBuffer;
  ReadStream: TStream;
  FileDescriptor: PFileDescriptor;
  FileSize: int64;
begin
  AStream := nil;

  FileDescriptor := PFileDescriptor(TVirtualFileStreamDataFormat(DataFormatAdapterSource.DataFormat).FileDescriptors[Index]);
  FileSize := int64(FileDescriptor.nFileSizeLow) or (int64(FileDescriptor.nFileSizeHigh) shr 32);

  // Warning:
  // This method will be called in the context of the transfer thread during an
  // asynchronous transfer. See TFormMain.OnProgress for a comment on this.

  // This event handler is called by TFileContentsStreamOnDemandClipboardFormat
  // when the drop target requests data from the drop source (that's us).
  Status := dsGetStream;

  RingBuffer := TRingBuffer.Create(16, 1024*64);

  ReadStream := TFifoStream.CreateForRead(RingBuffer, FileSize);

  // Return the stream back to the target as an IStream. Note that the
  // target is responsible for deleting the stream (via reference counting).
  AStream := TFifoStreamAdapter.Create(ReadStream, soOwned);

  PostMessage(Handle, MSG_TRANSFER, Index, integer(RingBuffer));
end;

procedure TFormMain.MsgTransfer(var Message: TMessage);
var
  Index: integer;
  Filename: string;
  FileDescriptor: PFileDescriptor;
  RingBuffer: TRingBuffer;
begin
  Index := Message.WParam;
  RingBuffer := TRingBuffer(Message.LParam);

  if (TransferInProgress) then
  begin
    PostMessage(Handle, MSG_TRANSFER, Index, integer(RingBuffer));
    exit;
  end;

  BeginTransfer;
  try
    FileDescriptor := PFileDescriptor(TVirtualFileStreamDataFormat(DataFormatAdapterSource.DataFormat).FileDescriptors[Index]);
    FCurrentFileSize := int64(FileDescriptor.nFileSizeLow) or (int64(FileDescriptor.nFileSizeHigh) shr 32);
    Filename := TVirtualFileStreamDataFormat(DataFormatAdapterSource.DataFormat).FileNames[Index];

    // Note: For this demo only low 32 bits of file size is used for progress bar
    ProgressBar1.Max := FCurrentFileSize and $FFFFFFFF;
    ProgressBar1.Position := 0;
    ProgressBar1.Show;