dropcomponent.pas

Delphi高级开发指南是开发程序的好帮手

unit DropComponent;

{ The TDropComponent component implements a simple file drop component
  that can be generically used by any Delphi application that is
  interested in receiving drag and drop notifications from the
  Windows shell.

  jfl
}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
    Dialogs, ActiveX, ComObj, ShellAPI;

type
  // Events
  TDropNotification = procedure( Sender: TObject; const FileNames: TStringList ) of object;

  TCustomDropComponent = class( TComponent )
  private
    FAllowMultipleFiles: Boolean;
    FFileNames: TStringList;
    FDropNotification: TDropNotification;
    FDropTarget: IDropTarget;
    FDropWindow: TWinControl;
    FEnabled: Boolean;
    FInstance: Pointer;
    FWnd: HWND;
    FWndProc: Pointer;
    procedure SetAllowMultipleFiles( Value: Boolean );
    procedure SetDropWindow( ADropWindow: TWinControl );
    procedure SetEnabled( Value: Boolean );
  protected
    procedure DoDropNotification( const FileNames: TStringList ); virtual;
    procedure Loaded; override;
    procedure Notification( AComponent: TComponent;
      Operation: TOperation ); override;
    procedure SubWndProc( var Message: TMessage );
    property AllowMultipleFiles: Boolean read FAllowMultipleFiles
      write SetAllowMultipleFiles default False;
    property DropNotification: TDropNotification read FDropNotification
      write FDropNotification;
    property DropWindow: TWinControl read FDropWindow write SetDropWindow;
    property Enabled: Boolean read FEnabled write SetEnabled default True;
  public
    constructor Create( AOwner: TComponent ); override;
    destructor Destroy; override;
    procedure Drop( const DataObject: IDataObject; const dwEffect: Integer ); virtual;
  end;

  TDropComponent = class( TCustomDropComponent )
  published
    property AllowMultipleFiles;
    property DropNotification;
    property DropWindow;
    property Enabled;
  end;

  THackWinControl = class( TWinControl )
  end;

procedure Register;

implementation

uses
  Interfaces;

{ Private }

procedure TCustomDropComponent.SetAllowMultipleFiles( Value: Boolean );
var
  initDropTarget: IInitDropTarget;
begin
  if Value <> FAllowMultipleFiles then
  begin
    FAllowMultipleFiles := Value;
    if Assigned( FDropTarget ) then
    begin
      // Signal our DropTarget object of the state change
      initDropTarget := FDropTarget as IInitDropTarget;
      initDropTarget.AllowMultipleFiles( Value );
    end;
  end;
end;

procedure TCustomDropComponent.SetDropWindow( ADropWindow: TWinControl );
begin
  if Assigned( FDropWindow ) then
    RevokeDragDrop( FDropWindow.Handle );

  if Assigned( ADropWindow ) then
  begin
    FDropWindow := ADropWindow;
    RegisterDragDrop( FDropWindow.Handle, FDropTarget );

    // Hook the window proc of the component so that we can receive
    // notifications when the actual HWND is destroyed.
    FWnd := FDropWindow.Handle;
    FWndProc := THackWinControl(FDropWindow).DefWndProc;
    THackWinControl(FDropWindow).DefWndProc :=
      MakeObjectInstance( SubWndProc );
  end;
end;

procedure TCustomDropComponent.SetEnabled( Value: Boolean );
var
  initDropTarget: IInitDropTarget;
begin
  if FEnabled <> Value then
  begin
    FEnabled := Value;
    if Assigned( FDropTarget ) then
    begin
      // Signal our DropTarget object of the state change
      initDropTarget := FDropTarget as IInitDropTarget;
      initDropTarget.Enabled( Value );
    end;
  end;
end;

{ Protected }

// Virtual function that fires the DropNotification event
procedure TCustomDropComponent.DoDropNotification(
  const FileNames: TStringList );
begin
  if Assigned( FDropNotification ) then
    FDropNotification( Self, FileNames );
end;

procedure TCustomDropComponent.Loaded;
var
  initDropTarget: IInitDropTarget;
begin
  // Transfer state to the DropTarget object
  if Assigned( FDropTarget ) then
  begin
    initDropTarget := FDropTarget as IInitDropTarget;
    initDropTarget.AllowMultipleFiles( FAllowMultipleFiles );
    initDropTarget.Enabled( True );
  end;

  inherited Loaded;
end;

// Make sure that we unregister the component if required
procedure TCustomDropComponent.Notification( AComponent: TComponent;
  Operation: TOperation );
begin
  if (Operation = opRemove) and not (csDestroying in ComponentState) then
    if AComponent = FDropWindow then
      FDropWindow := nil;
  inherited Notification( AComponent, Operation );
end;

{ Window Proc for subclassing the DropTarget Window. This is required
  so that we correctly unregister the window handle from the OLE
  libraries. }

procedure TCustomDropComponent.SubWndProc( var Message: TMessage );
begin
  with Message do
  begin
    if Msg = WM_DESTROY then
    begin
      OleCheck( RevokeDragDrop( FWnd ) );
      // Ensure freeing our thunk procedure later by saving its pointer
      FInstance := Pointer(GetWindowLong( FWnd, GWL_WNDPROC ));
    end;
    Result := CallWindowProc( FWndProc, FWnd, Msg, WParam, LParam );
  end;
end;

{ Public }

constructor TCustomDropComponent.Create( AOwner: TComponent );
var
  initDropTarget: IInitDropTarget;
begin
  OleInitialize( nil );
  FDropTarget := CreateComObject( Class_DropTarget ) as IDropTarget;
  initDropTarget := FDropTarget as IInitDropTarget;
  initDropTarget.SetDropTargetInstance( Self );
  FFileNames := TStringList.Create;
  inherited Create( AOwner );
end;

destructor TCustomDropComponent.Destroy;
begin
  // Free our subclassing thunk
  if Assigned( FInstance ) then
    FreeObjectInstance( FInstance );
    
  FFileNames.Free;
  OleUninitialize;
  inherited Destroy;
end;

procedure TCustomDropComponent.Drop( const DataObject: IDataObject;
  const dwEffect: Integer );
var
  buffer:     String;
  count, i:   Integer;
  formatEtc:  TFormatEtc;
  medium:     TStgMedium;
begin
  FFileNames.Clear;
  SetLength( buffer, MAX_PATH );

  with formatEtc do
  begin
    cfFormat    := CF_HDROP;
    ptd         := nil;
    dwAspect    := DVASPECT_CONTENT;
    lindex      := -1;
    tymed       := TYMED_HGLOBAL;
  end;
  OleCheck( DataObject.GetData( formatEtc, medium ) );

  try
    count := DragQueryFile( medium.hGlobal, -1, @buffer[ 1 ], MAX_PATH );
    for i := 0 to count - 1 do
    begin
      DragQueryFile( medium.hGlobal, i, @buffer[ 1 ], MAX_PATH );
      FFileNames.Add( String(PChar(buffer)) );
    end;
  finally
    ReleaseStgMedium( medium );
  end;
  DoDropNotification( FFileNames );
end;

procedure Register;
begin
  RegisterComponents( 'DDHB', [TDropComponent] );
end;

end.