jvdragdrop.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvDragDrop.PAS, released on 2001-02-28.

The Initial Developer of the Original Code is S閎astien Buysse [sbuysse att buypin dott com]
Portions created by S閎astien Buysse are Copyright (C) 2001 S閎astien Buysse.
All Rights Reserved.

Contributor(s): Michael Beck [mbeck att bigfoot dott com],
                Andreas Hausladen [Andreas dott Hausladen att gmx dott de].

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

Known Issues:
-----------------------------------------------------------------------------}
// $Id: JvDragDrop.pas,v 1.20 2005/02/17 10:20:26 marquardt Exp $

unit JvDragDrop;

{$I jvcl.inc}
{$I windowsonly.inc}

interface

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  Windows, Messages, ShellAPI, ActiveX, Classes, Controls,
  JvComponent;

type
  TJvDropTarget = class;
  TJvDragDrop = class;

  TJvDropEvent = procedure(Sender: TObject; Pos: TPoint; Value: TStrings) of object;
  TJvDropEffect = (deNone, deCopy, deMove, deLink, deScroll);

  TJvDragEvent = procedure(Sender: TJvDropTarget; var Effect: TJvDropEffect) of object;
  TJvDragDropEvent = procedure(Sender: TJvDropTarget; var Effect: TJvDropEffect;
    Shift: TShiftState; X, Y: Integer) of object;
  TJvDragLeaveEvent = procedure(Sender: TJvDropTarget) of object;
  TJvDragAcceptEvent = procedure(Sender: TJvDropTarget; var Accept: Boolean) of object;

  TJvDropTarget = class(TJvComponent, IDropTarget)
  private
    FDataObject: IDataObject;
    FStreamedAcceptDrag: Boolean;
    FControl: TWinControl;
    FOnDragDrop: TJvDragDropEvent;
    FOnDragAccept: TJvDragAcceptEvent;
    FOnDragEnter: TJvDragEvent;
    FOnDragOver: TJvDragEvent;
    FOnDragLeave: TJvDragLeaveEvent;
    FAcceptDrag: Boolean;
    procedure SetControl(Value: TWinControl);
    procedure SetAcceptDrag(Value: Boolean);
    procedure RegisterControl;
    procedure UnregisterControl;
  protected
    function DragEnter(const dataObj: IDataObject; grfKeyState: Longint;
      pt: TPoint; var dwEffect: Longint): HRESULT; stdcall;
    function DragOver(grfKeyState: Longint; pt: TPoint;
      var dwEffect: Longint): HRESULT; stdcall;
    function DragLeave: HRESULT; stdcall;
    function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint;
      var dwEffect: Longint): HRESULT; stdcall;
    function DoDragAccept: Boolean; dynamic;
    procedure DoDragEnter(var Effect: Longint); dynamic;
    procedure DoDragOver(var Effect: Longint); dynamic;
    procedure DoDragLeave; dynamic;
    procedure DoDragDrop(var Effect: Longint; Shift: TShiftState; X, Y: Integer); dynamic;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetFilenames(List: TStrings): Integer;
    // GetFilenames returns the HDROP Filenames. (same as TJvDragDrop).
    // Return value: number of filenames
    function GetFileDescrNames(List: TStrings): Integer;
    // GetFileDescrNames returns the File Descriptor file names (not available for Explorer drag/drop)
    function GetFileDescrCount: Integer;
    // GetFileDescrCount returns the number of File Descroptor file names.
    function GetFileContent(Index: Integer; Stream: TStream): Boolean;
    // GetFileContent returns the file content of the File Descriptor
    property DataObject: IDataObject read FDataObject;
  published
    property AcceptDrag: Boolean read FAcceptDrag write SetAcceptDrag default True;
    property Control: TWinControl read FControl write SetControl;
    property OnDragDrop: TJvDragDropEvent read FOnDragDrop write FOnDragDrop;
    property OnDragAccept: TJvDragAcceptEvent read FOnDragAccept write FOnDragAccept;
    property OnDragEnter: TJvDragEvent read FOnDragEnter write FOnDragEnter;
    property OnDragOver: TJvDragEvent read FOnDragOver write FOnDragOver;
    property OnDragLeave: TJvDragLeaveEvent read FOnDragLeave write FOnDragLeave;
  end;

  TJvDragDrop = class(TJvComponent)
  private
    FAcceptDrag: Boolean;
    FStreamedAcceptDrag: Boolean;
    FFiles: TStringList;
    FOnDrop: TJvDropEvent;
    FIsHooked: Boolean;
    FTargetStrings: TStrings;
    FDropTarget: TWinControl;
    procedure DropFiles(Handle: HDROP);
    function GetFiles: TStrings;
    procedure SetAcceptDrag(Value: Boolean);
    procedure SetDropTarget(const Value: TWinControl);
    function WndProc(var Msg: TMessage): Boolean;
  protected
    procedure HookControl;
    procedure UnHookControl;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Files: TStrings read GetFiles;
    property TargetStrings: TStrings read FTargetStrings write FTargetStrings;
  published
    property AcceptDrag: Boolean read FAcceptDrag write SetAcceptDrag default True;
    property DropTarget: TWinControl read FDropTarget write SetDropTarget;
    property OnDrop: TJvDropEvent read FOnDrop write FOnDrop;
  end;

function CF_FILEDESCRIPTOR: DWORD;
function CF_FILECONTENTS: DWORD;
function Malloc: IMalloc;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvDragDrop.pas,v $';
    Revision: '$Revision: 1.20 $';
    Date: '$Date: 2005/02/17 10:20:26 $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation

uses
  ShlObj, SysUtils, Forms,
  {$IFDEF COMPILER5}
  JvJCLUtils,
  {$ENDIF COMPILER5}
  JvWndProcHook;

var
  GlobalCF_FILEDESCRIPTOR: DWORD = $FFFFFFF;
  GlobalCF_FILECONTENTS: DWORD = $FFFFFFF;
  GlobalMalloc: IMalloc = nil;

  FileDropFormatEtc: FORMATETC;
  FileContentFormatEtc: FORMATETC;
  FileDescriptorFormatEtc: FORMATETC;

function CF_FILEDESCRIPTOR: DWORD;
begin
  if GlobalCF_FILEDESCRIPTOR = $FFFFFFF then
    GlobalCF_FILEDESCRIPTOR := RegisterClipboardFormat(CFSTR_FILEDESCRIPTOR);
  Result := GlobalCF_FILEDESCRIPTOR;
end;

function CF_FILECONTENTS: DWORD;
begin
  if GlobalCF_FILECONTENTS = $FFFFFFF then
    GlobalCF_FILECONTENTS := RegisterClipboardFormat(CFSTR_FILECONTENTS);
  Result := GlobalCF_FILECONTENTS;
end;

function Malloc: IMalloc;
begin
  if not Assigned(GlobalMalloc) then
    ShGetMalloc(GlobalMalloc);
  Result := GlobalMalloc;
end;

//=== { TJvDragDrop } ========================================================

constructor TJvDragDrop.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAcceptDrag := False;
  FStreamedAcceptDrag := True;
  FFiles := TStringList.Create;
  FIsHooked := False;
  if (Owner is TWinControl) and (csDesigning in ComponentState) then
    FDropTarget := TWinControl(Owner);
end;

destructor TJvDragDrop.Destroy;
begin
  UnHookControl;
  FFiles.Free;
  inherited Destroy;
end;

procedure TJvDragDrop.Loaded;
begin
  inherited Loaded;
  SetAcceptDrag(FStreamedAcceptDrag);
end;

procedure TJvDragDrop.DropFiles(Handle: HDROP);
var
  Buffer: PChar;
  I, BufferLength, NeededLength: Integer;
  MousePt: TPoint;
  Count: Integer;
begin
  FFiles.Clear;

  BufferLength := MAX_PATH;

  { Note: Do not use fixed stack buffers of size MAX_PATH,
          to prevent buffer overrun attacks, be paranoid <g> }
  GetMem(Buffer, BufferLength);
  try
    { Return value is a count of the dropped files }
    Count := DragQueryFile(Handle, $FFFFFFFF, nil, 0);

    for I := 0 to Count-1 do
    begin
      { Return value is the required size, in characters, of the buffer,
        *not* including the terminating null character (hence the + 1) }
      NeededLength := DragQueryFile(Handle, I, nil, 0) + 1;
      if NeededLength > BufferLength then
      begin
        BufferLength := NeededLength;
        ReallocMem(Buffer, BufferLength);
      end;
      DragQueryFile(Handle, I, Buffer, BufferLength);
      FFiles.Add(Buffer);
    end;
  finally
    FreeMem(Buffer);
  end;

  if Assigned(FTargetStrings) then
    FTargetStrings.Assign(FFiles);

  if Assigned(FOnDrop) then
  begin
    DragQueryPoint(Handle, MousePt);
    FOnDrop(Self, MousePt, FFiles);
  end;

  DragFinish(Handle);
end;

procedure TJvDragDrop.HookControl;
begin
  if not FIsHooked then
    { Paranoia checks }
    if Assigned(FDropTarget) and not (csDesigning in ComponentState) then
      FIsHooked := RegisterWndProcHook(FDropTarget, WndProc, hoBeforeMsg);
end;

procedure TJvDragDrop.UnHookControl;
begin
  if FIsHooked then
  begin
    FIsHooked := False;
    { Paranoia checks }
    if Assigned(FDropTarget) and not (csDesigning in ComponentState) then
      UnRegisterWndProcHook(FDropTarget, WndProc, hoBeforeMsg);
  end;
end;

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

  if (AComponent = FDropTarget) and (Operation = opRemove) then
    DropTarget := nil;
end;

procedure TJvDragDrop.SetAcceptDrag(Value: Boolean);
begin
  if csLoading in ComponentState then
    { When loading, delay changing to active until all properties are loaded }
    FStreamedAcceptDrag := Value
  else
  if Value <> FAcceptDrag then
  begin
    FAcceptDrag := Value;

    if Assigned(FDropTarget) and not (csDesigning in ComponentState) then
    begin
      { If the component is being destroyed, we don't want to call its Handle
        property, which will implicitly re-create its already destroyed handle }
      if not (csDestroying in FDropTarget.ComponentState) then
        DragAcceptFiles(FDropTarget.Handle, FAcceptDrag);

      if FAcceptDrag then
        HookControl
      else
        UnHookControl;
    end;
  end;
end;

function TJvDragDrop.GetFiles: TStrings;
begin
  Result := FFiles;
end;

procedure TJvDragDrop.SetDropTarget(const Value: TWinControl);
var
  WasActive: Boolean;
begin
  if csLoading in ComponentState then
    FDropTarget := Value
  else
  if Value <> FDropTarget then
  begin
    WasActive := AcceptDrag;

    { This will implicitly unhook the current DropTarget }
    AcceptDrag := False;

    if Assigned(FDropTarget) then
      FDropTarget.RemoveFreeNotification(Self);

    FDropTarget := Value;

    if Assigned(FDropTarget) then
      FDropTarget.FreeNotification(Self);

    if WasActive then
      { And hook again.. }
      AcceptDrag := True;
  end;
end;

function TJvDragDrop.WndProc(var Msg: TMessage): Boolean;
begin
  Result := Msg.Msg = WM_DROPFILES;
  if Result then
    DropFiles(HDROP(Msg.WParam));
end;


//=== { TJvDropTarget } ======================================================

procedure InitFormatEtc;
begin
  if FileDescriptorFormatEtc.cfFormat <> 0 then
    Exit;

  with FileDropFormatEtc do
  begin
    cfFormat := CF_HDROP;
    ptd := nil;
    dwAspect := DVASPECT_CONTENT;
    lindex := 0;
    tymed := TYMED_HGLOBAL;
  end;

  with FileDescriptorFormatEtc do
  begin
    cfFormat := CF_FILEDESCRIPTOR;
    ptd := nil;
    dwAspect := DVASPECT_CONTENT;
    lindex := -1;
    tymed := TYMED_HGLOBAL;
  end;

  with FileContentFormatEtc do
  begin
    cfFormat := CF_FILECONTENTS;
    ptd := nil;
    dwAspect := DVASPECT_CONTENT;
    lindex := 0;
    tymed := TYMED_ISTREAM;
  end;
end;

procedure GetDropEffect(Effect: Longint; var Eff: TJvDropEffect);
begin
  Eff := deNone;
  if (Effect and DROPEFFECT_NONE) <> 0 then
    Eff := deNone