{-----------------------------------------------------------------------------
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?stien Buysse [sbuysse att buypin dott com]
Portions created by S?stien Buysse are Copyright (C) 2001 S?stien 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 10630 2006-05-31 15:42:19Z ahuser $

unit JvDragDrop;

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

interface

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

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: UINT;
function CF_FILECONTENTS: UINT;
function Malloc: IMalloc;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/tags/JVCL3_32/run/JvDragDrop.pas $';
    Revision: '$Revision: 10630 $';
    Date: '$Date: 2006-05-31 17:42:19 +0200 (mer., 31 mai 2006) $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation

uses
  ShlObj, SysUtils, Forms,
  JvVCL5Utils,
  JvJCLUtils,
  JvWndProcHook;

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

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

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

function CF_FILECONTENTS: UINT;
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;
  FAcceptDrag := False;
  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
  else
  if (Effect and DROPEFFECT_COPY) <> 0 then
    Eff := deCopy
  else
  if (Effect and DROPEFFECT_MOVE) <> 0 then
    Eff := deMove
  else
  if (Effect and DROPEFFECT_LINK) <> 0 then
    Eff := deLink
  else
  if (Effect and DROPEFFECT_SCROLL) <> 0 then
    Eff := deScroll;
end;

procedure SetDropEffect(var Effect: Longint; Eff: TJvDropEffect);
begin
  case Eff of
    deNone:
      Effect := DROPEFFECT_NONE;
    deCopy:
      Effect := DROPEFFECT_COPY;
    deMove:
      Effect := DROPEFFECT_MOVE;
    deLink:
      Effect := DROPEFFECT_LINK;
    deScroll:
      Effect := Longint(DROPEFFECT_SCROLL);
  end;
end;

constructor TJvDropTarget.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Malloc; // a simple call prevents Delphi from crashing

  FAcceptDrag := True;
  FStreamedAcceptDrag := True;

  InitFormatEtc;
end;

destructor TJvDropTarget.Destroy;
begin
  UnregisterControl;
  FDataObject := nil;
  inherited Destroy;
end;

function TJvDropTarget.DragEnter(const dataObj: IDataObject; grfKeyState: Longint;
  pt: TPoint; var dwEffect: Longint): HRESULT;
begin
  FDataObject := dataObj;
  Result := S_OK;

  if not DoDragAccept then
  begin
    FDataObject := nil;
    dwEffect := DROPEFFECT_NONE;
  end
  else
  begin
    dwEffect := DROPEFFECT_COPY;
    try
      DoDragEnter(dwEffect);
    except
      Result := E_UNEXPECTED;
    end;
  end;
end;

function TJvDropTarget.DragOver(grfKeyState: Longint; pt: TPoint;
  var dwEffect: Longint): HRESULT;
begin
  Result := S_OK;
  if FDataObject = nil then
  begin
    FDataObject := nil;
    dwEffect := DROPEFFECT_NONE;
  end
  else
  begin
    dwEffect := DROPEFFECT_COPY;
    try
      DoDragOver(dwEffect);
    except
      Result := E_UNEXPECTED;
    end;
  end;
end;

function TJvDropTarget.DragLeave: HRESULT;
begin
  try
    DoDragLeave;
    Result := S_OK;
  except
    Result := E_UNEXPECTED;
  end;
  FDataObject := nil;
end;

function TJvDropTarget.Drop(const dataObj: IDataObject; grfKeyState: Longint;
  pt: TPoint; var dwEffect: Longint): HRESULT;
begin
  Result := S_OK;
  if FDataObject = nil then
  begin
    FDataObject := nil;
    dwEffect := DROPEFFECT_NONE;
  end
  else
  begin
    dwEffect := DROPEFFECT_COPY;
    try
      DoDragDrop(dwEffect, KeyDataToShiftState(grfKeyState), pt.X, pt.Y);
    except
      Result := E_UNEXPECTED;
    end;
    FDataObject := nil;
  end;
end;

function TJvDropTarget.DoDragAccept: Boolean;
begin
  Result := True;
  if Assigned(FOnDragAccept) then
    FOnDragAccept(Self, Result);
end;

procedure TJvDropTarget.DoDragEnter(var Effect: Longint);
var
  Eff: TJvDropEffect;
begin
  GetDropEffect(Effect, Eff);
  if Assigned(FOnDragEnter) then
    FOnDragEnter(Self, Eff);
  SetDropEffect(Effect, Eff);
end;

procedure TJvDropTarget.DoDragOver(var Effect: Longint);
var
  Eff: TJvDropEffect;
begin
  GetDropEffect(Effect, Eff);
  if Assigned(FOnDragOver) then
    FOnDragOver(Self, Eff);
  SetDropEffect(Effect, Eff);
end;

procedure TJvDropTarget.DoDragLeave;
begin
  if Assigned(FOnDragLeave) then
    FOnDragLeave(Self);
end;

procedure TJvDropTarget.DoDragDrop(var Effect: Longint; Shift: TShiftState;
  X, Y: Integer);
var
  Eff: TJvDropEffect;
begin
  GetDropEffect(Effect, Eff);
  if Assigned(FOnDragDrop) then
    FOnDragDrop(Self, Eff, Shift, X, Y);
  SetDropEffect(Effect, Eff);
end;

procedure TJvDropTarget.SetControl(Value: TWinControl);
begin
  if Value <> FControl then
  begin
    UnregisterControl;
    if Assigned(FControl) then
      FControl.RemoveFreeNotification(Self);

    FControl := Value;

    if Assigned(FControl) then
      FControl.FreeNotification(Self);
      
    RegisterControl;
  end;
end;

procedure TJvDropTarget.RegisterControl;
begin
  if FAcceptDrag and Assigned(FControl) and not (csDesigning in ComponentState) then
  begin
    if RegisterDragDrop(FControl.Handle, Self) <> S_OK then
      RaiseLastOSError;
  end;
end;

procedure TJvDropTarget.UnregisterControl;
begin
  if FAcceptDrag and Assigned(FControl) and not (csDesigning in ComponentState) then
    if FControl.HandleAllocated then
      RevokeDragDrop(FControl.Handle);
end;

procedure TJvDropTarget.SetAcceptDrag(Value: Boolean);
begin
  if csLoading in ComponentState then
    FStreamedAcceptDrag := Value
  else
  if Value <> FAcceptDrag then
  begin
    UnregisterControl;
    FAcceptDrag := Value;
    RegisterControl;
  end;
end;

procedure TJvDropTarget.Loaded;
begin
  inherited Loaded;
  AcceptDrag := FStreamedAcceptDrag;
end;

procedure TJvDropTarget.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FControl) then
    Control := nil;
end;

function TJvDropTarget.GetFileDescrNames(List: TStrings): Integer;
var
  FileGroupDescr: PFileGroupDescriptor;
  Medium: TStgMedium;
  I: Integer;
  S: string;
begin
  Result := 0;
  if FDataObject.GetData(FileDescriptorFormatEtc, Medium) = S_OK then
  begin
    try
      try
        FileGroupDescr := GlobalLock(Medium.hGlobal);
        try
          if List <> nil then
            for I := 0 to FileGroupDescr.cItems - 1 do
            begin
              SetString(S, FileGroupDescr^.fgd[I].cFileName, StrLen(FileGroupDescr^.fgd[I].cFileName));
              List.Add(S);
            end;
          Result := FileGroupDescr.cItems;
        finally
          GlobalUnlock(Medium.hGlobal);
        end;
      finally
        ReleaseStgMedium(Medium);
      end;
    except
      Result := 0;
    end;
  end;
end;

function TJvDropTarget.GetFileDescrCount: Integer;
var
  FileGroupDescr: PFileGroupDescriptor;
  Medium: TStgMedium;
begin
  Result := 0;
  if FDataObject.GetData(FileDescriptorFormatEtc, Medium) = S_OK then
    try
      try
        FileGroupDescr := GlobalLock(Medium.hGlobal);
        try
          Result := FileGroupDescr.cItems;
        finally
          GlobalUnlock(Medium.hGlobal);
        end;
      finally
        ReleaseStgMedium(Medium);
      end;
    except
      Result := 0;
    end;
end;

function TJvDropTarget.GetFilenames(List: TStrings): Integer;
var
  DragH: Integer;
  Medium: TStgMedium;
  Name: string;
  I, Count, Len: Integer;
begin
  Result := 0;
  if FDataObject.GetData(FileDropFormatEtc, Medium) = S_OK then
    try
      try
        DragH := Integer(GlobalLock(Medium.hGlobal));
        try
          Count := DragQueryFile(DragH, Cardinal(-1), nil, 0);
          if List <> nil then
            for I := 0 to Count - 1 do
            begin
              Len := DragQueryFile(DragH, I, nil, 0);
              if Len > 0 then
              begin
                SetLength(Name, Len + 1);
                DragQueryFile(DragH, I, PChar(Name), Len + 1);
                SetLength(Name, Len);
                List.Add(Name);
              end;
            end;
          Result := Count;
        finally
          GlobalUnlock(Medium.hGlobal);
        end;
      finally
        ReleaseStgMedium(Medium);
      end;
    except
      Result := 0;
    end;
end;

function TJvDropTarget.GetFileContent(Index: Integer; Stream: TStream): Boolean;
const
  MaxBufSize = 100 * 1024;
var
  Medium: TStgMedium;
  InStream: IStream;
  Stat: TStatStg;

  Buf: Pointer;
  BufSize: Integer;
  Num: Int64;
  Position: Int64;
begin
  Result := False;
  if (Stream = nil) or (Index < 0) or (Index >= GetFileDescrCount) then
    Exit;

  FileContentFormatEtc.lindex := Index;
  if FDataObject.GetData(FileContentFormatEtc, Medium) = S_OK then
    try
      try
        if Medium.tymed and TYMED_ISTREAM <> 0 then
        begin
          InStream := IStream(Medium.stm);
          InStream.Stat(Stat, STATFLAG_NONAME);
          Num := Stat.cbSize;
          if Num > 0 then
          begin
            GetMem(Buf, MaxBufSize);
            try
             // Speicherbereich reservieren
              Position := Stream.Position;
              Stream.Size := Stream.Size + Num;
              Stream.Position := Position;

              while Num > 0 do
              begin
                if Num < MaxBufSize then
                  BufSize := Num
                else
                  BufSize := MaxBufSize;
                InStream.Read(Buf, BufSize, nil);
                Stream.Write(Buf^, BufSize);
                Dec(Num, BufSize);
              end;
            finally
              FreeMem(Buf);
            end;
          end;
        end
        else
          Result := False;
      finally
        ReleaseStgMedium(Medium);
      end;
    except
      Result := False;
    end;
end;

initialization
  {$IFDEF UNITVERSIONING}
  RegisterUnitVersion(HInstance, UnitVersioning);
  {$ENDIF UNITVERSIONING}
  OleInitialize(nil);

finalization
  OleUninitialize;
  {$IFDEF UNITVERSIONING}
  UnregisterUnitVersion(HInstance);
  {$ENDIF UNITVERSIONING}

end.