DropFilesTarget, Version 1.2 (alt)

{
  DropFilesTarget.pas

  Delphi unit containing the non-visual component TDropFilesTarget which
  implements the DragAcceptFiles / WM_DROPFILES API for any control that
  has a window handle (TWinControl descendant).

  Version 1.2 - always find the most current version at
  http://flocke.vssd.de/prog/code/pascal/dft/

  Copyright (C) 2005 Volker Siebert <flocke@vssd.de>
  All rights reserved.

  Permission is hereby granted, free of charge, to any person obtaining a
  copy of this software and associated documentation files (the "Software"),
  to deal in the Software without restriction, including without limitation
  the rights to use, copy, modify, merge, publish, distribute, sublicense,
  and/or sell copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following conditions:

  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
}

unit DropFilesTarget;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, ShellApi;

type
  TDropFilesInfo = class(TPersistent)
  private
    FControl: TWinControl;          // Drop action target control
    FStamp: TDateTime;              // Timestamp of drop action
    FPoint: TPoint;                 // Drop point
    FFiles: TStrings;               // List with filenames
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    property Control: TWinControl read FControl;
    property Files: TStrings read FFiles;
    property Point: TPoint read FPoint;
    property Stamp: TDateTime read FStamp;
  end;

  TDropFilesEvent = procedure(Sender: TObject; Info: TDropFilesInfo) of object;

  TDropFilesTarget = class(TComponent)
  private
    FTargetControl: TWinControl;    // Target control to accept WM_DROPFILES
    FEnabled: Boolean;              // Enable/disable accepting
    FOnDropFiles: TDropFilesEvent;  // Notification handler
    FAcceptingWindow: HWND;         // Window handle that got "DragAcceptFiles"
    FOldWndProc: TWndMethod;        // Old WindowProc method
    procedure DropFiles(hDrop: HDROP);
    procedure NewWndProc(var Msg: TMessage);
    procedure AttachControl;
    procedure DetachControl;
    procedure SetEnabled(AEnabled: Boolean);
    procedure SetTargetControl(AControl: TWinControl);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property TargetControl: TWinControl read FTargetControl write SetTargetControl;
    property OnDropFiles: TDropFilesEvent read FOnDropFiles write FOnDropFiles;
  end;

procedure Register;

implementation

{ TDropFilesInfo }

constructor TDropFilesInfo.Create;
begin
  inherited;
  FFiles := TStringList.Create;
end;

destructor TDropFilesInfo.Destroy;
begin
  FreeAndNil(FFiles);
  inherited;
end;

procedure TDropFilesInfo.Assign(Source: TPersistent);
begin
  if Source is TDropFilesInfo then
  begin
    FControl := TDropFilesInfo(Source).Control;
    FStamp := TDropFilesInfo(Source).Stamp;
    FPoint := TDropFilesInfo(Source).Point;
    FFiles.Assign(TDropFilesInfo(Source).Files);
  end
  else
    inherited Assign(Source);
end;

{ TDropFilesTarget }

constructor TDropFilesTarget.Create(AOwner: TComponent);
begin
  inherited;
  FEnabled := true;
end;

destructor TDropFilesTarget.Destroy;
begin
  TargetControl := nil;  // This detaches any attached control
  inherited;
end;

procedure TDropFilesTarget.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited;

  if Operation = opRemove then
    if AComponent = FTargetControl then
      TargetControl := nil;
end;

{ Do the dropping. Note that DragFinish is called in the window
  procedure and not here.
}
procedure TDropFilesTarget.DropFiles(hDrop: HDROP);
var
  Info: TDropFilesInfo;
  Count, Index, Len: Integer;
  Filename: PChar;
begin
  Info := TDropFilesInfo.Create;
  try
    Info.FStamp := Now;
    Info.FControl := FTargetControl;
    DragQueryPoint(hDrop, Info.FPoint);

    Count := DragQueryFile(hDrop, $ffffffff, nil, 0);
    for Index := 0 to Count - 1 do
    begin
      Len := DragQueryFile(hDrop, Index, nil, 0);
      Filename := AllocMem(Len + 1);
      try
        DragQueryFile(hDrop, Index, Filename, Len + 1);
        TStringList(Info.FFiles).Add(StrPas(Filename));
      finally
        FreeMem(Filename);
      end;
    end;

    FOnDropFiles(Self, Info);
  finally
    Info.Free;
  end;
end;

{ The new Window procedure for the attached drop target control.
}
procedure TDropFilesTarget.NewWndProc(var Msg: TMessage);
begin
  if Msg.Msg = WM_DROPFILES then
  begin
    try
      if Assigned(FOnDropFiles) then
        DropFiles(Msg.WParam);
    finally
      DragFinish(Msg.WParam);
    end;
    Msg.Result := 0;
  end
  else
  begin
    if Msg.Msg = WM_DESTROY then
      if FAcceptingWindow <> 0 then
        // Don't clear FAcceptingWindow
        DragAcceptFiles(FAcceptingWindow, false);

    FOldWndProc(Msg);

    if Msg.Msg = WM_CREATE then
      // Make it believe the window handle must be refreshed
      FAcceptingWindow := 0;

    if FTargetControl.HandleAllocated then
      if FAcceptingWindow <> FTargetControl.Handle then
      begin
        FAcceptingWindow := FTargetControl.Handle;
        DragAcceptFiles(FAcceptingWindow, true);
      end;
  end;
end;

{ Attach to FTargetControl: subclass, force a window handle and call
  DragAcceptFiles with Accept=true.
}
procedure TDropFilesTarget.AttachControl;
begin
  if [csDesigning, csDestroying] * ComponentState <> [] then
    exit;

  if (FTargetControl = nil) or (not FEnabled) then
    exit;

  if [csDesigning, csDestroying] * FTargetControl.ComponentState <> [] then
    exit;

  FOldWndProc := FTargetControl.WindowProc;
  FTargetControl.WindowProc := NewWndProc;

  // Note: If we don't force a handle here we get problems with controls
  // that call ReCreateWnd before they even got a handle (-> RichEdit).
  FTargetControl.HandleNeeded;
  FAcceptingWindow := FTargetControl.Handle;
  DragAcceptFiles(FAcceptingWindow, true);
end;

{ Detach from FTargetControl: call DragAcceptFiles with Accept=false and
  remove subclassing.
}
procedure TDropFilesTarget.DetachControl;
begin
  if FAcceptingWindow <> 0 then
  begin
    DragAcceptFiles(FAcceptingWindow, false);
    FAcceptingWindow := 0;
  end;

  if @FOldWndProc <> nil then
  begin
    FTargetControl.WindowProc := FOldWndProc;
    FOldWndProc := nil;
  end;
end;

procedure TDropFilesTarget.SetEnabled(AEnabled: Boolean);
begin
  if FEnabled <> AEnabled then
  begin
    DetachControl;
    FEnabled := AEnabled;
    AttachControl;
  end;
end;

procedure TDropFilesTarget.SetTargetControl(AControl: TWinControl);
begin
  if FTargetControl <> AControl then
  begin
    DetachControl;

    if FTargetControl <> nil then
      FTargetControl.RemoveFreeNotification(Self);

    FTargetControl := AControl;

    if FTargetControl <> nil then
      FTargetControl.FreeNotification(Self);

    AttachControl;
  end;
end;

{ Register }

procedure Register;
begin
  RegisterComponents('System', [TDropFilesTarget]);
end;

end.