winscp/source/packages/dragndrop/DragDrop.pas

unit DragDrop;
{
  Description
  ===========
    TDragDrop is a component for OLE drag-and-drop operations. The component
    is able to make successor components of TWinControl to the source AND
    target of drag-and-drop operations.


  Disclaimer
  ==========
    The author disclaims all warranties, expressed or implied, including,
    without limitation, the warranties of merchantability and of fitness
    for any purpose. The author assumes no liability for damages, direct or
    consequential, which may result from the use of this component/unit.


  Restrictions on Using the Unit / Component
  ==========================================
    This unit/component is copyright 1998 by Dieter Steinwedel. ALL RIGHTS
    ARE RESERVED BY DIETER STEINWEDEL. You are allowed to use it freely
    subject to the following restrictions:

    • You are not allowed delete or alter the author's name and
      copyright in any manner

    • You are not allowed to publish a copy, modified version or
      compilation neither for payment in any kind nor freely

    • You are allowed to create a link to the download in the WWW

    • These restrictions and terms apply to you as long as until
      I alter them. Changes can found on my homepage
}

{$ALIGN ON}
{$ASSERTIONS OFF}
{$BOOLEVAL OFF}
{$DENYPACKAGEUNIT OFF}
{$EXTENDEDSYNTAX ON}
{$HINTS ON}
{$IMPORTEDDATA ON}
{$LONGSTRINGS ON}
{$OPTIMIZATION ON}
{$TYPEDADDRESS OFF}
{$TYPEINFO OFF}
{$WARNINGS ON}
{$WARN SYMBOL_DEPRECATED OFF}

interface

uses
  SysUtils, Windows, Classes, Controls, Forms, ShellApi,
  Menus, Messages, Graphics, ActiveX, ExtCtrls, Grids;

{MP}(*$HPPEMIT '#include <oleidl.h>'*)

const
  DefaultCursor = 0;

type
  IEnumFormatEtc = ActiveX.IEnumFormatEtc;
  IDataObject = ActiveX.IDataObject;
  TFormatEtc = ActiveX.TFormatEtc;
  TStgMedium = ActiveX.TStgMedium;

  TDropEffect = (deCopy, deMove, deLink);
  TDragResult = (drInvalid, drCancelled, drCopy, drMove, drLink);
  TDropEffectSet = set of TDropEffect;
  TDragDetectStatus = (ddsNone, ddsLeft, ddsRight, ddsCancelled, ddsDrag);
  TRenderDataOn = (rdoEnter, rdoEnterAndDropSync, rdoEnterAndDropAsync, rdoDropSync, rdoDropAsync, rdoNever);
  TSrcCompatibilityCheck = (CheckLindex, CheckdwAspect);
  TSrcCompatibilityCheckSet = set of TSrcCompatibilityCheck;
  TScrollInterval = 1..10000;
  TScrollDirection = (sdUp, sdDown, sdLeft, sdRight);

  // event handlers ...

  TOnDragEnter = procedure(DataObj: IDataObject; grfKeyState: LongInt; pt: TPoint;
     var dwEffect: LongInt; var Accept: Boolean) of object;
  // WORKAROUND C++Builder 11.2 cannot compile parameter-less Delphi closures
  TOnDragLeave = procedure(Dummy: Integer) of object;
  TOnDragOver = procedure(grfKeyState: LongInt; pt: TPoint; var dwEffect: LongInt; PreferredEffect: LongInt) of object;
  TOnDrop = procedure(DataObj: IDataObject; grfKeyState: LongInt;  pt: TPoint; var dwEffect: LongInt) of object;
  TOnQueryContinueDrag = procedure(fEscapePressed: BOOL; grfKeyState: LongInt; var Result: HResult) of object;
  TOnGiveFeedback = procedure(dwEffect: LongInt; var Result: HResult) of object;
  TOnDragDetect = procedure(grfKeyState: LongInt; DetectStart, pt: TPoint; DragDetectStatus: TDragDetectStatus) of object;
  TOnProcessDropped = procedure(Sender: TObject; grfKeyState: LongInt;  pt: TPoint; dwEffect: LongInt) of object;
  TOnBeforeScrolling = procedure(Sender: TObject; pt: TPoint; var Interval: TScrollInterval;
     ScrollDirection: TScrollDirection; var ScrollPage: Boolean) of object;
  TOnMenuPopup = procedure(Sender: TObject; AMenu: HMenu; DataObj: IDataObject;
     AMinCustCmd: Integer; grfKeyState: LongInt; pt: TPoint) of object;
  TOnMenuExecCmd = procedure(Sender: TObject; AMenu: HMenu; DataObj: IDataObject;
     Command: Integer; var dwEffect: LongInt; var Succeeded: Boolean) of object;
  TOnMenuDestroy = procedure(Sender: TObject; AMenu: HMenu) of object;

  TFormatEtcArray = array of TFormatEtc;

  // list classes ...

  TFormatEtcList = class
  private
     FCount: Integer;
     FList: TFormatEtcArray;
     function Get(Index: Integer): TFormatEtc;
     procedure Put(Index: Integer; Item: TFormatEtc);
  public
     constructor Create;
     destructor Destroy; override;
     function Add(Item: TFormatEtc): Integer;
     procedure Clear;
     procedure Delete(Index: Integer);
     function Clone: TFormatEtcList;
     property Count: Integer read FCount;
     property Items[Index: Integer]: TFormatEtc read Get write Put;
  end;

  // inherited classes ...
  TDDInterfacedObject = class(TInterfacedObject)
  public
     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
     function _AddRef: Integer; stdcall;
     function _Release: Integer; stdcall;
  end;

  TEnumFormatEtc = class(TDDInterfacedObject, IEnumFormatEtc)
  protected
    FFormatEtcList: TFormatEtcList;
    FIndex: Integer;
  public
    constructor Create(FormatEtcList: TFormatEtcList);
    destructor Destroy; override;
    function Next(celt: LongInt; out elt; pceltFetched: PLongInt): HResult; stdcall;
    function Skip(celt: LongInt): HResult; stdcall;
    function Reset: HResult; stdcall;
    function Clone(out Enum: IEnumFormatEtc): HResult; stdcall;
  end;

  TDataObject = class(TDDInterfacedObject, IDataObject)
  protected
    FFormatEtcList: TFormatEtcList;
    FCheckLindex: Boolean;
    FCheckdwAspect: Boolean;
  public
    constructor Create;
    destructor Destroy; override;
    function GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult; stdcall;
    function GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult; stdcall;
    function QueryGetData(const formatetc: TFormatEtc): HResult; stdcall;
    function GetCanonicalFormatEtc(const formatetc: TFormatEtc; out formatetcOut: TFormatEtc): HResult; stdcall;
    function SetData(const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult; stdcall;
    function EnumFormatEtc(dwDirection: LongInt; out enumFormatEtc: IEnumFormatEtc): HResult; stdcall;
    function DAdvise(const formatetc: TFormatEtc; advf: LongInt;
      const advSink: IAdviseSink; out dwConnection: LongInt): HResult; stdcall;
    function DUnadvise(dwConnection: LongInt): HResult; stdcall;
    function EnumDAdvise(out enumAdvise: IEnumStatData): HResult; stdcall;
    function RenderData(FormatEtc:TFormatEtc; var StgMedium: TStgMedium): HResult; virtual; abstract;
  protected
    function AllowData(FormatEtc: TFormatEtc): Boolean; virtual;
  end;

  // forward declaration, because TDropSource and TDropTarget uses this class ...
  TDragDrop = class;

  TDropSource = class(TDDInterfacedObject, IDropSource)
  private
    FOwner: TDragDrop;
  public
    constructor Create(AOwner: TDragDrop);
    destructor Destroy; override;
    function QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: LongInt): HResult; stdcall;
    function GiveFeedback(dwEffect: LongInt): HResult; stdcall;
  end;

  TDropTarget = class(TDDInterfacedObject, IDropTarget)
  private
    FAccept: Boolean;
    HorzStartTimer: TTimer;
    HorzScrollTimer: TTimer;
    VertStartTimer: TTimer;
    VertScrollTimer: TTimer;
    FVScrollCode: Integer;
    FHScrollCode: Integer;
    FPreferredEffect: LongInt;
    procedure InitScroll(VerticalScroll: Boolean; ScrollCode: Integer);
    procedure TermScroll(VerticalScroll: Boolean);
    procedure DetermineScrollDir(VertScrolling: Boolean; var ScrollCode: Integer);
    procedure OnStartTimer(Sender: TObject);
    procedure OnScrollTimer(Sender: TObject);
  protected
    FOwner: TDragDrop;
    procedure SuggestDropEffect(grfKeyState: LongInt; var dwEffect: LongInt); virtual;
    procedure AcceptDataObject(DataObj: IDataObject; var Accept:Boolean); virtual;
    procedure RenderDropped(DataObj: IDataObject; grfKeyState: LongInt; pt: TPoint; var dwEffect: LongInt); virtual;
  public
    constructor Create(AOwner: TDragDrop);
    destructor Destroy; override;
    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;
  end;

  // custom properties

  TScrollDetectArea = class(TPersistent)
  private
    FControl: TPersistent;
    FMargin: Word;
    FRange: Word;
    FOnChange: TNotifyEvent;
    procedure SetValue(Index: Integer; Value: Word);
  protected
    procedure Change; dynamic;
    procedure AssignTo(Dest: TPersistent); override;
    property Control: TPersistent read FControl;
  public
    constructor Create(Control: TPersistent);
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  published
    property Margin: Word index 0 read FMargin write SetValue default 0;
    property Range: Word index 1 read FRange write SetValue default 10;
  end;

  TScrollDetectOptions = class(TPersistent)
  private
    FControl: TDragDrop;
    FScrollDelay: TScrollInterval;
    FStartDelay: TScrollInterval;
    FLeft: TScrollDetectArea;
    FTop: TScrollDetectArea;
    FRight: TScrollDetectArea;
    FBottom: TScrollDetectArea;
    FOnChange: TNotifyEvent;
    FHorzScrolling: Boolean;
    FVertScrolling: Boolean;
    FHorzPageScroll: Boolean;
    FVertPageScroll: Boolean;
    procedure SetValue(Index: Integer; Value: TScrollInterval);
  protected
    procedure Change; dynamic;
    procedure AssignTo(Dest: TPersistent); override;
    property Control: TDragDrop read FControl;
  public
    constructor Create(Control: TDragDrop);
    destructor Destroy; override;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  published
    property ScrollDelay: TScrollInterval index 0 read FScrollDelay write SetValue default 100;
    property StartDelay: TScrollInterval index 1 read FStartDelay write SetValue default 750;
    property AreaLeft: TScrollDetectArea read FLeft write FLeft;
    property AreaTop: TScrollDetectArea read FTop write FTop;
    property AreaRight: TScrollDetectArea read FRight write FRight;
    property AreaBottom: TScrollDetectArea read FBottom write FBottom;
    property HorzScrolling: Boolean read FHorzScrolling write FHorzScrolling default False;
    property VertScrolling: Boolean read FVertScrolling write FVertScrolling default False;
    property HorzPageScroll: Boolean read FHorzPageScroll write FHorzPageScroll default False;
    property VertPageScroll: Boolean read FVertPageScroll write FVertPageScroll default False;
  end;

  // *THE* pseudo-visual Component
  TDragDrop = class(TComponent)
  private
    FAutoDetectDnD: Boolean;
    FDragDetectDelta: Byte;
    FAcceptOwnDnD: Boolean;
    FBTF: Boolean;
    FContextMenu: Boolean;
    FDragDropControl: TWinControl;
    FRegistered: Boolean;
    FOwnerIsSource: Boolean;
    FShowPopUpMenu: Boolean;
    FTargetEffectsSet: TDropEffectSet;
    FTargetEffects: LongInt;
    FOnQueryContinueDrag: TOnQueryContinueDrag;
    FOnGiveFeedback: TOnGiveFeedback;
    FOnDragEnter: TOnDragEnter;
    FOnDragLeave: TOnDragLeave;
    FOnDragOver: TOnDragOver;
    FOnDrop: TOnDrop;
    FSourceEffectsSet: TDropEffectSet;
    FSourceEffects: LongInt;
    FOnProcessDropped: TOnProcessDropped;
    OldWndProc: Pointer;
    WndProcPtr: Pointer;
    FOnDragDetect: TOnDragDetect;
    FDragDetectStatus: TDragDetectStatus;
    FDragDetectStart: TPoint;
    FRenderDataOn: TRenderDataOn;
    FDataObj: IDataObject;
    FgrfKeyState: LongInt;
    Fpt: TPoint;
    FdwEffect: LongInt;
    FCHCopy: HCursor;
    FCHMove: HCursor;
    FCHLink: HCursor;
    FCHScrollCopy: HCursor;
    FCHScrollMove: HCursor;
    FCHScrollLink: HCursor;
    FMessageHooked: Boolean;
    FAvailableDropEffects: LongInt;
    FTargetScrolling: Integer;
    FSrcCompatibilityCheck: TSrcCompatibilityCheckSet;
    FScrollDetectOptions: TScrollDetectOptions;
    FOnBeforeScrolling: TOnBeforeScrolling;
    FOnAfterScrolling: TNotifyEvent;
    FPressedButton: Integer;
    FInternalSource: TDragDrop;
    FOnMenuPopup: TOnMenuPopup;
    FOnMenuExecCmd: TOnMenuExecCmd;
    FOnMenuDestroy: TOnMenuDestroy;
    FOnMenuSucceeded: TOnProcessDropped;
    FOnDropHandlerSucceeded: TOnProcessDropped;
    procedure WndMethod(var Msg: TMessage);
    procedure SetDragDropControl(WinControl: TWinControl);
    procedure SetSourceEffects(Values: TDropEffectSet);
    procedure SetTargetEffects(Values: TDropEffectSet);
  protected
    FDropTarget: TDropTarget;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function CreateDataObject: TDataObject; virtual; abstract;
    procedure DoMenuPopup(Sender: TObject; AMenu: HMenu; DataObj: IDataObject;
       AMinCustCmd: Integer; grfKeyState: LongInt; pt: TPoint); virtual;
    function DoMenuExecCmd(Sender: TObject; AMenu: HMenu; DataObj: IDataObject;
       Command: Integer; var dwEffect: LongInt): Boolean; virtual;
    procedure DoMenuDestroy(Sender: TObject; AMenu: HMenu); virtual;
    function DropHandler(const dataObj: IDataObject; grfKeyState: LongInt;
       pt: TPoint; var dwEffect: LongInt): Boolean; virtual;
    property OnDropHandlerSucceeded: TOnProcessDropped read FOnDropHandlerSucceeded write FOnDropHandlerSucceeded;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function RegisterTarget: Boolean;
    function UnRegisterTarget: Boolean;
    procedure HookMessageHandler;
    procedure UnhookMessageHandler(ForceUnhook: Boolean);
    function ExecuteOperation(DataObject: TDataObject): TDragResult;
    function Execute: TDragResult;
    function CopyToClipboard: Boolean; virtual;
    function GetFromClipboard: Boolean; virtual;
    procedure StartDnDDetection(Button: TMouseButton); virtual;
    property OwnerIsSource:Boolean read FOwnerIsSource;
    property Registered: Boolean read FRegistered default False;
    property CHCopy: HCursor read FCHCopy write FCHCopy default DefaultCursor;
    property CHMove: HCursor read FCHMove write FCHMove default DefaultCursor;
    property CHLink: HCursor read FCHLink write FCHLink default DefaultCursor;
    property CHScrollCopy: HCursor read FCHScrollCopy write FCHScrollCopy default DefaultCursor;
    property CHScrollMove: HCursor read FCHScrollMove write FCHScrollMove default DefaultCursor;
    property CHScrollLink: HCursor read FCHScrollLink write FCHScrollLink default DefaultCursor;
    property DragDetectStatus: TDragDetectStatus read FDragDetectStatus;
    property AvailableDropEffects: LongInt read FAvailableDropEffects;
    property InternalSource: TDragDrop read FInternalSource;
  published
    property AcceptOwnDnD: Boolean read FAcceptOwnDnD write FAcceptOwnDnD;
    property AutoDetectDnD: Boolean read FAutoDetectDnD write FAutoDetectDnD;
    property BringToFront: Boolean read FBTF write FBTF;
    property DragDetectDelta: Byte read FDragDetectDelta write FDragDetectDelta default 10;
    property DragDropControl: TWinControl read FDragDropControl write SetDragDropControl;
    property RenderDataOn: TRenderDataOn read FRenderDataOn write FRenderDataOn default rdoDropSync;
    property ScrollDetectOptions: TScrollDetectOptions read FScrollDetectOptions write FScrollDetectOptions;
    property SourceCompatibility: TSrcCompatibilityCheckSet read FSrcCompatibilityCheck write FSrcCompatibilityCheck;
    property SourceEffects: TDropEffectSet read FSourceEffectsSet write SetSourceEffects;
    property TargetPopupMenu: Boolean read FShowPopUpMenu write FShowPopUpMenu;
    property TargetEffects: TDropEffectSet read FTargetEffectsSet write SetTargetEffects;
    property OnAfterScrolling: TNotifyEvent read FOnAfterScrolling write FOnAfterScrolling;
    property OnBeforeScrolling: TOnBeforeScrolling read FOnBeforeScrolling write FOnBeforeScrolling;
    property OnDragDetect: TOnDragDetect read FOnDragDetect write FOnDragDetect;
    property OnDragEnter: TOnDragEnter read FOnDragEnter write FOnDragEnter;
    property OnDragLeave: TOnDragLeave read FOnDragLeave write FOnDragLeave;
    property OnDragOver: TOnDragOver read FOnDragOver write FOnDragOver;
    property OnDrop: TOnDrop read FOnDrop write FOnDrop;
    property OnQueryContinueDrag: TOnQueryContinueDrag read FOnQueryContinueDrag write FOnQueryContinueDrag;
    property OnGiveFeedback: TOnGiveFeedback read FOnGiveFeedback write FOnGiveFeedback;
    property OnProcessDropped: TOnProcessDropped read FOnProcessDropped write FOnProcessDropped;
    property OnMenuPopup: TOnMenuPopup read FOnMenuPopup write FOnMenuPopup;
    property OnMenuExecCmd: TOnMenuExecCmd read FOnMenuExecCmd write FOnMenuExecCmd;
    property OnMenuDestroy: TOnMenuDestroy read FOnMenuDestroy write FOnMenuDestroy;
    property OnMenuSucceeded: TOnProcessDropped read FOnMenuSucceeded write FOnMenuSucceeded;
  end;

procedure Register;

resourcestring
  MICopyStr = '&Copy Here';
  MIMoveStr = '&Move Here';
  MILinkStr = '&Shortcut(s) Create Here';
  MIAbortStr = '&Abort';

implementation

uses
  PIDL;

const
  CmdAbort = 0;
  CmdMove = 1;
  CmdCopy = 2;
  CmdLink = 3;
  CmdSeparator = 4;
  MinCustCmd = 10;

var
  DDM_ProcessDropped: DWord; // Never change its value
  MouseHookHandle: HHook;
  MouseHookDragDrop: TDragDrop;
  GInternalSource: TDragDrop;

function MouseHookProc(Code: Integer; wparam: WPARAM; lparam: LPARAM): LRESULT; stdcall;
var
  MouseHookStruct: TMouseHookStruct;
  grfKeyState: LongInt;
begin
  Result := CallNextHookEx(MouseHookHandle, Code, wParam, lParam);
  if not Assigned(MouseHookDragDrop) then
  begin
    UnHookWindowsHookEx(MouseHookHandle);
    MouseHookHandle := 0;
  end
    else
  with MouseHookDragDrop do
  begin
    MouseHookStruct := TMouseHookStruct(Pointer(lparam)^);
    if ((FDragDetectStatus = ddsRight) and (wParam = WM_LBUTTONDOWN)) or
       ((FDragDetectStatus = ddsLeft) and (wParam = WM_RBUTTONDOWN)) then
    begin
      FPressedButton := 2;
      FDragDetectStatus := ddsCancelled;
      if Assigned(FOnDragDetect) then
      begin
        if HiWord(DWord(GetKeyState(VK_SHIFT))) <> 0 then grfKeyState:=MK_SHIFT
          else grfKeyState := 0;
        if HiWord(DWord(GetKeyState(VK_CONTROL))) <> 0 then
          grfKeyState := grfKeyState or MK_CONTROL;
        FOnDragDetect(grfKeyState,
          FDragDropControl.ScreenToClient(FDragDetectStart),
          FDragDropControl.ScreenToClient(MouseHookStruct.pt),
          FDragDetectStatus);
      end;
      exit;
    end;
    if ((wParam = WM_LBUTTONDOWN) or (wParam = WM_RBUTTONDOWN)) and
       (FDragDetectStatus = ddsCancelled) then
    begin
      FPressedButton:=2;
      exit;
    end;
    if (FDragDetectStatus = ddsCancelled) and
       ((wParam = WM_LBUTTONUP) or (wParam = WM_RBUTTONUP)) then
    begin
      Dec(FPressedButton);
      if FPressedButton <= 0 then
      begin
        UnHookWindowsHookEx(MouseHookHandle);
        MouseHookHandle := 0;
        FDragDetectStatus := ddsNone;
        if Assigned(FOnDragDetect) then
        begin
          if HiWord(DWord(GetKeyState(VK_SHIFT))) <> 0 then grfKeyState := MK_SHIFT
            else grfKeyState := 0;
          if HiWord(DWord(GetKeyState(VK_CONTROL))) <> 0 then
            grfKeyState := grfKeyState or MK_CONTROL;
          FOnDragDetect(grfKeyState,
            FDragDropControl.ScreenToClient(FDragDetectStart),
            FDragDropControl.ScreenToClient(MouseHookStruct.pt),
            FDragDetectStatus);
        end;
      end;
      exit;
    end;
    if ((FDragDetectStatus = ddsRight) and (wParam = WM_RBUTTONUP)) or
       ((FDragDetectStatus = ddsLeft) and (wParam = WM_LBUTTONUP)) then
    begin
      UnHookWindowsHookEx(MouseHookHandle);
      MouseHookHandle := 0;
      FDragDetectStatus := ddsNone;
      if Assigned(FOnDragDetect) then
      begin
        if HiWord(DWord(GetKeyState(VK_SHIFT))) <> 0 then grfKeyState := MK_SHIFT
          else grfKeyState := 0;
        if HiWord(DWord(GetKeyState(VK_CONTROL))) <> 0 then
          grfKeyState := grfKeyState or MK_CONTROL;
        FOnDragDetect(grfKeyState,
          FDragDropControl.ScreenToClient(FDragDetectStart),
          FDragDropControl.ScreenToClient(MouseHookStruct.pt),
          FDragDetectStatus);
      end;
      exit;
    end;
    if ((Abs(FDragDetectStart.X - MouseHookStruct.pt.x) > DragDetectDelta) or
        (Abs(FDragDetectStart.Y - MouseHookStruct.pt.y) > DragDetectDelta)) and
       ((FDragDetectStatus = ddsRight) or (FDragDetectStatus = ddsLeft)) then
    begin
      FDragDetectStatus := ddsDrag;
      UnHookWindowsHookEx(MouseHookHandle);
      MouseHookHandle := 0;
      if Assigned(FOnDragDetect) then
      begin
        if HiWord(DWord(GetKeyState(VK_SHIFT))) <> 0 then grfKeyState := MK_SHIFT
          else grfKeyState := 0;
        if HiWord(DWord(GetKeyState(VK_CONTROL))) <> 0 then
          grfKeyState := grfKeyState or MK_CONTROL;
        FOnDragDetect(grfKeyState,
          FDragDropControl.ScreenToClient(FDragDetectStart),
          FDragDropControl.ScreenToClient(MouseHookStruct.pt),
          FDragDetectStatus);
      end;
      if FDragDetectStatus<>ddsNone then
      begin
        FDragDetectStatus := ddsNone;
        if Assigned(FOnDragDetect) then
        begin
          if HiWord(DWord(GetKeyState(VK_SHIFT))) <> 0 then grfKeyState:=MK_SHIFT
            else grfKeyState := 0;
          if HiWord(DWord(GetKeyState(VK_CONTROL))) <> 0 then
            grfKeyState := grfKeyState or MK_CONTROL;
          FOnDragDetect(grfKeyState,
            FDragDropControl.ScreenToClient(FDragDetectStart),
            FDragDropControl.ScreenToClient(MouseHookStruct.pt),
            FDragDetectStatus);
        end;
      end;
    end;
  end;
end;

// TFormatEtcList --------------------------------------------------------------

constructor TFormatEtcList.Create;
begin
  inherited;
  FCount := 0;
  SetLength(FList, 0);
end;

destructor TFormatEtcList.Destroy;
begin
  if (FCount > 0) and (FList <> nil) then SetLength(FList, 0);
  inherited;
end;

function TFormatEtcList.Get(Index: Integer): TFormatEtc;
begin
  if (Index >= FCount) or (FList = nil) then raise EListError.Create('Invalid item index')
    else Result := FList[Index];
end;

procedure TFormatEtcList.Put(Index: Integer; Item: TFormatEtc);
begin
  if (Index >= FCount) or (FList = nil) then raise EListError.Create('Invalid item index')
    else FList[Index] := Item;
end;

function TFormatEtcList.Add(Item: TFormatEtc): Integer;
begin
  SetLength(FList, Succ(FCount));
  FList[FCount] := Item;
  Result := FCount;
  Inc(FCount);
end;

procedure TFormatEtcList.Clear;
begin
  SetLength(Flist, 0);
  FCount := 0;
end;

function TFormatEtcList.Clone: TFormatEtcList;
var
  FEL: TFormatEtcList;
begin
  FEL := TFormatEtcList.Create;
  if FList <> nil then
  begin
    SetLength(FEL.FList, FCount);
    CopyMemory(FEL.FList, FList, FCount * SizeOf(TFormatEtc));
    FEL.FCount:=FCount;
  end;
  Result := FEL;
end;

procedure TFormatEtcList.Delete(Index: Integer);
var
  MoveCount: Integer;
begin
  if (Index >= FCount) or (FList = nil) then raise EListError.Create('Invalid item index')
    else
  begin
    MoveCount := FCount-Index-1;
    System.Move(FList[Index+1], FList[Index], MoveCount * SizeOf(TFormatEtc));
    Dec(FCount);
    SetLength(FList, FCount);
  end;
end;

// TDDInterfacedObject ---------------------------------------------------------

function TDDInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  Result := inherited QueryInterface(IID, Obj);
end;

function TDDInterfacedObject._AddRef: Integer;
begin
  Result := inherited _AddRef;
end;

function TDDInterfacedObject._Release: Integer;
begin
  Result := inherited _Release;
end;

// TEnumFormatEtc --------------------------------------------------------------

constructor TEnumFormatEtc.Create(FormatEtcList: TFormatEtcList);
begin
  inherited Create;
  _AddRef;
  FFormatEtcList := FormatEtcList;
end;

destructor TEnumFormatEtc.Destroy;
begin
  if Assigned(FFormatEtcList) then FFormatEtcList.Free;
  inherited;
end;

function TEnumFormatEtc.Next(celt: LongInt; out elt; pceltFetched: PLongint): HResult;
var
  CopyCount: Integer;
begin
  Result := S_False;
  if pceltFetched <> nil then pceltFetched^ := 0;
  if (celt <= 0) or (FFormatEtcList.Count = 0) or (FIndex >= FFormatEtcList.Count) or
     ((pceltFetched = nil) and (celt <> 1)) then
  begin
    // noop
  end
    else
  begin
    CopyCount := FFormatEtcList.Count - FIndex;
    if celt < CopyCount then CopyCount := celt;
    if pceltFetched <> nil then pceltFetched^ := CopyCount;
    CopyMemory(@TFormatEtc(elt), @TFormatEtc(FFormatEtcList.FList[FIndex]), CopyCount * SizeOf(TFormatEtc));
    Inc(FIndex, CopyCount);
    Result := S_OK;
  end;
end;

function TEnumFormatEtc.Skip(celt: LongInt): HResult;
begin
  if FIndex + celt <= FFormatEtcList.Count then
  begin
    Inc(FIndex, celt);
    Result := S_OK;
  end
    else Result := S_False;
end;

function TEnumFormatEtc.Reset: HResult;
begin
  FIndex := 0;
  Result := S_OK;
end;

function TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult;
begin
  Result := S_OK;
  try
    Enum := TEnumFormatEtc.Create(FFormatEtcList);
    TEnumFormatEtc(Enum).FIndex := FIndex;
  except
    Result := E_Fail;
  end;
end;

// TDataObject -----------------------------------------------------------------

constructor TDataObject.Create;
begin
  inherited;
  _AddRef;
  FFormatEtcList := TFormatEtcList.Create;
end;

destructor TDataObject.Destroy;
begin
  FFormatEtcList.Free;
  inherited;
end;

function TDataObject.GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult;
var
  i: Integer;
  Cursor: TCursor;
begin
  try
    if FFormatEtcList.Count>0 then
    begin
      for i := 0 to FFormatEtcList.Count - 1 do
      begin
        if ((formatetcIn.tymed and FFormatEtcList.Items[i].tymed) <> 0) and
           ((not FCheckLindex) or (FCheckLindex and (formatetcIn.lindex = FFormatEtcList.Items[i].lindex))) and
           ((not FCheckdwAspect) or (FCheckdwAspect and (formatetcIn.dwAspect = FFormatEtcList.Items[i].dwAspect))) and
           (formatetcIn.cfFormat = FFormatEtcList.Items[i].cfFormat) then
        begin
          Cursor := Screen.Cursor;
          try
            Screen.Cursor := crHourglass;
            Result := RenderData(formatetcIn, medium);
          finally
            Screen.Cursor := Cursor;
          end;
          exit;
        end;
      end;
    end;
    Result := DV_E_FormatEtc;
  except
     medium.HGlobal := 0;
     Result := E_Fail;
  end;
end;

function TDataObject.GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult;
begin
  Result := E_NOTIMPL;
end;

function TDataObject.GetCanonicalFormatEtc(const formatetc: TFormatEtc; out formatetcOut: TFormatEtc): HResult;
begin
  Result := E_NOTIMPL;
end;

function TDataObject.QueryGetData(const formatetc: TFormatEtc): HResult;
const
  DVError: array[0..3] of HResult = (DV_E_FORMATETC, DV_E_TYMED, DV_E_DVASPECT, DV_E_LINDEX);
var
  i, j: Integer;
begin
  j := 0;
  if (FFormatEtcList.Count>0) and AllowData(FormatEtc) then
  begin
    for i := 0 to FFormatEtcList.Count - 1 do
    begin
      if FormatEtc.cfFormat = FFormatEtcList.Items[i].cfFormat then
      begin
        if (FormatEtc.tymed and FFormatEtcList.Items[i].tymed) <> 0 then
        begin
          if FormatEtc.dwAspect = FFormatEtcList.Items[i].dwAspect then
          begin
            if FormatEtc.lindex = FFormatEtcList.Items[i].lindex then
            begin
              Result := S_OK;
              exit;
            end
              else
            if j < 3 then j := 3;
          end
            else
          if j < 2 then j := 2;
        end
          else
        if j < 1 then j := 1;
      end;
    end;
  end;
  Result := DVError[j];
end;

function TDataObject.AllowData(FormatEtc: TFormatEtc): Boolean;
begin
  Result := True;
end;

function TDataObject.EnumFormatEtc(dwDirection: LongInt; out enumFormatEtc: IEnumFormatEtc): HResult;
begin
  Result := E_Fail;
  if dwDirection = DATADIR_GET then
  begin
    EnumFormatEtc := TEnumFormatEtc.Create(FFormatEtcList.Clone);
    Result := S_OK;
  end
    else EnumFormatEtc := nil;
  if EnumFormatEtc = nil then Result := OLE_S_USEREG;
end;

function TDataObject.SetData(const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult;
var
  i: Integer;
  AddData: Boolean;
begin
  Result := E_Fail;
  if not FRelease then
  begin
    AddData := True;
    if FFormatEtcList.Count>0 then
    begin
      for i := 0 to FFormatEtcList.Count - 1 do
      begin
        if FFormatEtcList.Items[i].cfFormat = FormatEtc.cfFormat then
        begin
          AddData := False;
          FFormatEtcList.Items[i] := FormatEtc;
        end;
      end;
    end;
    if AddData then
    begin
      FFormatEtcList.Add(FormatEtc);
    end;
  end;
end;

function  TDataObject.DAdvise(
  const formatetc: TFormatEtc; advf: LongInt; const advSink: IAdviseSink; out dwConnection: LongInt): HResult;
begin
  Result := E_NOTIMPL;
end;

function TDataObject.DUnadvise(dwConnection: LongInt): HResult; stdcall;
begin
  Result := E_NOTIMPL;
end;

function TDataObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult;
begin
  Result := OLE_E_AdviseNotSupported;
end;

// TDropSource methods ---------------------------------------------------------

constructor TDropSource.Create(AOwner: TDragDrop);
begin
  inherited Create;
   _AddRef;
   FOwner := AOwner;
end;

destructor TDropSource.Destroy;
begin
  inherited;
end;

function TDropSource.QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: LongInt): HResult; stdcall;
// Determines whether a drag-and-drop operation should be continued, cancelled,
// or completed. You do not call this method directly. The OLE DoDragDrop function
// calls this method during a drag-and-drop operation.
begin
  // Abort drag-and-drop?
  if (((grfKeyState and MK_LBUTTON) <> 0) and
      ((grfKeyState and MK_RBUTTON) <> 0)) or fEscapePressed then
  begin
    Result := DRAGDROP_S_CANCEL;
    FOwner.FOwnerIsSource := False;
  end
  // Finish drag-and-drop?
  else if (((grfKeyState and MK_LBUTTON) = 0) and
           ((grfKeyState and MK_RBUTTON) = 0)) then
  begin
    Result := DRAGDROP_S_DROP;
  end
    else
  begin
    Result := S_OK;
  end;
  if Assigned(FOwner.FOnQueryContinueDrag) then
  begin
    FOwner.FOnQueryContinueDrag(fEscapePressed, grfKeyState, Result);
  end;
end;

function TDropSource.GiveFeedback(dwEffect: LongInt): HResult; stdcall;
// Enables a source application to give visual feedback to its end user
// during a drag-and-drop operation by providing the DoDragDrop function
// with an enumeration value specifying the visual effect.
var
  HC: HCursor;
begin
  if Assigned(FOwner.FOnGiveFeedback) then FOwner.FOnGiveFeedback(dwEffect,Result);
  if dwEffect and DROPEFFECT_SCROLL <> 0 then
  begin
    if dwEffect and DROPEFFECT_LINK <> 0 then HC := FOwner.FCHScrollLink
      else
    if dwEffect and DROPEFFECT_MOVE <> 0 then HC := FOwner.FCHScrollMove
      else
    if dwEffect and DROPEFFECT_COPY <> 0 then HC := FOwner.FCHScrollCopy
      else HC := DefaultCursor;
  end
    else
  begin
    if dwEffect and DROPEFFECT_LINK <> 0 then HC := FOwner.FCHLink
      else
    if dwEffect and DROPEFFECT_MOVE <> 0 then HC := FOwner.FCHMove
      else
    if dwEffect and DROPEFFECT_COPY <> 0 then HC := FOwner.FCHCopy
      else HC := DefaultCursor;
  end;

  if HC = DefaultCursor then
  begin
    Result := DRAGDROP_S_USEDEFAULTCURSORS
  end
    else
  begin
    Result := S_OK;
    Windows.SetCursor(HC);
  end;
end;

// TDropTarget interface -------------------------------------------------------

constructor TDropTarget.Create(AOwner: TDragDrop);
begin
  inherited Create;
  FOwner := AOwner;
  _AddRef;
  HorzStartTimer := TTimer.Create(FOwner);
  HorzStartTimer.Enabled := False;
  HorzStartTimer.OnTimer := OnStartTimer;
  HorzScrollTimer := TTimer.Create(FOwner);
  HorzScrollTimer.Enabled := False;
  HorzScrollTimer.OnTimer := OnScrollTimer;
  VertStartTimer := TTimer.Create(FOwner);
  VertStartTimer.Enabled := False;
  VertStartTimer.OnTimer := OnStartTimer;
  VertScrollTimer := TTimer.Create(FOwner);
  VertScrollTimer.Enabled := False;
  VertScrollTimer.OnTimer := OnScrollTimer;
  FVScrollCode := 0;
  FHScrollCode := 0;
end;

destructor TDropTarget.Destroy;
begin
  HorzStartTimer.Free;
  HorzScrollTimer.Free;
  VertStartTimer.Free;
  VertScrollTimer.Free;
  inherited Destroy;
end;

procedure TDropTarget.InitScroll(VerticalScroll: Boolean; ScrollCode: Integer);
begin
  TermScroll(VerticalScroll);
  if VerticalScroll then
  begin
    VertStartTimer.Interval := FOwner.FScrollDetectOptions.FStartDelay;
    VertStartTimer.Enabled := True;
    FVScrollCode := ScrollCode;
  end
    else
  begin
    HorzStartTimer.Interval := FOwner.FScrollDetectOptions.FStartDelay;
    HorzStartTimer.Enabled := True;
    FHScrollCode := ScrollCode;
  end;
end;

procedure TDropTarget.TermScroll(VerticalScroll: Boolean);
begin
  if VerticalScroll then
  begin
    VertStartTimer.Enabled := False;
    if VertScrollTimer.Enabled then
      SendMessage(FOwner.DragDropControl.Handle, WM_VSCROLL, SB_ENDSCROLL, 0);
    VertScrollTimer.Enabled := False;
    FVScrollCode := 0;
  end
    else
  begin
    HorzStartTimer.Enabled := False;
    if HorzScrollTimer.Enabled then
      SendMessage(FOwner.DragDropControl.Handle, WM_HSCROLL, SB_ENDSCROLL, 0);
    HorzScrollTimer.Enabled := False;
    FHScrollCode := 0;
  end;
end;

procedure TDropTarget.DetermineScrollDir(VertScrolling: Boolean; var ScrollCode: Integer);
var
  p1m, p1r, p2m, p2r: Integer;
  ptmc: TPoint;
  ScrollInfo: TScrollInfo;
begin
  GetCursorPos(ptmc);
  ptmc := FOwner.DragDropControl.ScreenToClient(ptmc);
  if VertScrolling then
  begin
    // Checking vertical scroll areas ...
    // If the vertical scroll areas intersect, we don't allow scrolling
    p1m := FOwner.FScrollDetectOptions.AreaTop.Margin;
    p1r := p1m + FOwner.ScrollDetectOptions.AreaTop.Range;
    p2m := FOwner.DragDropControl.ClientHeight - 1 - FOwner.ScrollDetectOptions.AreaBottom.Margin;
    p2r := p2m - FOwner.ScrollDetectOptions.AreaBottom.Range;
    if p1r < p2r then
    begin
      if (p1m <= ptmc.y) and (p1r >= ptmc.y) then ScrollCode := 1
        else
      if (p2m >= ptmc.y) and (p2r <= ptmc.y) then ScrollCode := 2
        else ScrollCode := 0;

      if ScrollCode > 0 then
      begin
        ScrollInfo.cbSize := Sizeof(ScrollInfo);
        ScrollInfo.FMask := SIF_PAGE or SIF_POS or SIF_RANGE;
        if GetScrollInfo(FOwner.DragDropControl.Handle, SB_VERT, ScrollInfo) then
        begin
          if ScrollInfo.nPage > 0 then Dec(ScrollInfo.nPage);

          if ((ScrollCode=1) and (ScrollInfo.nPos <= ScrollInfo.nMin)) or
             ((ScrollCode=2) and (ScrollInfo.nPos >= ScrollInfo.nMax - Integer(ScrollInfo.nPage))) then
          begin
            ScrollCode := 0;
          end;
        end
          else ScrollCode := 0;
      end;
    end
      else ScrollCode := 0;
  end
    else
  begin
    // Checking horizontal scroll areas ...
    // If the horizontal scroll areas intersect, we don't allow scrolling
    p1m := FOwner.FScrollDetectOptions.AreaLeft.Margin;
    p1r := p1m + FOwner.ScrollDetectOptions.AreaLeft.Range;
    p2m := FOwner.DragDropControl.ClientWidth - 1 - FOwner.ScrollDetectOptions.AreaRight.Margin;
    p2r := p2m - FOwner.ScrollDetectOptions.AreaRight.Range;
    if p1r < p2r then
    begin
      if (p1m <= ptmc.x) and (p1r >= ptmc.x) then ScrollCode := 1
        else
      if (p2m >= ptmc.x) and (p2r <= ptmc.x) then ScrollCode := 2
        else ScrollCode := 0;

      if ScrollCode>0 then
      begin
        ScrollInfo.cbSize := Sizeof(ScrollInfo);
        ScrollInfo.FMask := SIF_PAGE or SIF_POS or SIF_RANGE;
        if GetScrollInfo(FOwner.DragDropControl.Handle, SB_HORZ, ScrollInfo) then
        begin
          if ScrollInfo.nPage > 0 then Dec(ScrollInfo.nPage);

          if ((ScrollCode=1) and (ScrollInfo.nPos <= ScrollInfo.nMin)) or
             ((ScrollCode=2) and (ScrollInfo.nPos >= ScrollInfo.nMax - Integer(ScrollInfo.nPage))) then
          begin
             ScrollCode := 0;
          end;
        end
          else ScrollCode := 0;
      end;
    end
      else ScrollCode := 0;
  end;
end;

procedure TDropTarget.OnStartTimer(Sender: TObject);
var
  StartTimer: TTimer;
  ScrollTimer: TTimer;
begin
  if Sender = HorzStartTimer then
  begin
    StartTimer := HorzStartTimer;
    ScrollTimer := HorzScrollTimer;
  end
    else
  begin
    StartTimer := VertStartTimer;
    ScrollTimer := VertScrollTimer;
  end;

  StartTimer.Enabled := False;
  ScrollTimer.Interval := FOwner.FScrollDetectOptions.FScrollDelay;
  OnScrollTimer(ScrollTimer);
  ScrollTimer.Enabled := True;
end;

procedure TDropTarget.OnScrollTimer(Sender: TObject);
var
  ScrollPage: Boolean;
  pt: TPoint;
  Interval: TScrollInterval;
  ScrollCode, SCWParam: Integer;
begin
  Interval:=FOwner.FScrollDetectOptions.FScrollDelay;
  if Sender = VertScrollTimer then
  begin
    if FOwner.FScrollDetectOptions.FVertScrolling then
    begin
      DetermineScrollDir(True, ScrollCode);
      if ScrollCode > 0 then
      begin
        if ((not VertStartTimer.Enabled) and (not VertScrollTimer.Enabled)) or
           (FVScrollCode <> ScrollCode) then
        begin
          InitScroll(True, ScrollCode);
        end
          else
        begin
          ScrollPage := FOwner.FScrollDetectOptions.FVertPageScroll;
          if Assigned(FOwner.FOnBeforeScrolling) then
          begin
            GetCursorPos(pt);
            pt := FOwner.DragDropControl.ScreenToClient(pt);
            if FVScrollCode = 1 then FOwner.FOnBeforeScrolling(FOwner, pt, Interval, sdUp, ScrollPage)
              else FOwner.FOnBeforeScrolling(FOwner, pt, Interval, sdDown, ScrollPage);
          end;
          if ScrollPage then
          begin
            if FVScrollCode = 1 then SCWParam := SB_PAGEUP
              else SCWParam := SB_PAGEDOWN;
          end
            else
          begin
            if FVScrollCode = 1 then SCWParam := SB_LINEUP
              else SCWParam := SB_LINEDOWN;
          end;
          SendMessage(FOwner.DragDropControl.Handle, WM_VSCROLL, SCWParam, 0);
          if Assigned(FOwner.FOnAfterScrolling) then
            FOwner.FOnAfterScrolling(FOwner);
          VertScrollTimer.Interval := Interval;
        end;
      end
        else
      if FVScrollCode <> 0 then TermScroll(True);
    end
      else
    if FVScrollCode <> 0 then TermScroll(True);
  end
    else
  begin
    if FOwner.FScrollDetectOptions.FHorzScrolling then
    begin
      DetermineScrollDir(False, ScrollCode);
      if ScrollCode>0 then
      begin
        if ((not HorzStartTimer.Enabled) and (not HorzScrollTimer.Enabled)) or
           (FHScrollCode <> ScrollCode) then
        begin
          InitScroll(False, ScrollCode);
        end
          else
        begin
          ScrollPage := FOwner.FScrollDetectOptions.FHorzPageScroll;
          if Assigned(FOwner.FOnBeforeScrolling) then
          begin
            GetCursorPos(pt);
            pt := FOwner.DragDropControl.ScreenToClient(pt);
            if FHScrollCode = 1 then FOwner.FOnBeforeScrolling(FOwner, pt, Interval, sdLeft, ScrollPage)
              else FOwner.FOnBeforeScrolling(FOwner, pt, Interval, sdRight, ScrollPage);
          end;
          if ScrollPage then
          begin
            if FHScrollCode = 1 then SCWParam := SB_PAGELEFT
              else SCWParam := SB_PAGERIGHT;
          end
            else
          begin
            if FHScrollCode = 1 then SCWParam := SB_LINELEFT
              else SCWParam := SB_LINERIGHT;
          end;
          SendMessage(FOwner.DragDropControl.Handle, WM_HSCROLL, SCWParam, 0);
          HorzScrollTimer.Interval := Interval;
        end;
      end
        else
      if FHScrollCode <> 0 then TermScroll(False);
    end
      else
    if FHScrollCode <> 0 then TermScroll(False);
  end;
end;

procedure TDropTarget.SuggestDropEffect(grfKeyState: LongInt; var dwEffect: LongInt);
begin
  if (not FOwner.FAcceptOwnDnD) and FOwner.FOwnerIsSource then dwEffect := DROPEFFECT_NONE
    else
  if (((grfKeyState and MK_CONTROL = 0) and (grfKeyState and MK_SHIFT <> 0)) or
      (FPreferredEffect and DROPEFFECT_MOVE <> 0)) and
     (FOwner.FTargetEffects and DROPEFFECT_MOVE <> 0) then dwEffect := DROPEFFECT_MOVE
    else
  if (((grfKeyState and MK_CONTROL <> 0) and (grfKeyState and MK_SHIFT <> 0)) or
      (FPreferredEffect and DROPEFFECT_LINK <> 0)) and
     (FOwner.FTargetEffects and DROPEFFECT_LINK <> 0) then dwEffect := DROPEFFECT_LINK
    else
  if (deCopy in FOwner.FTargetEffectsSet) and (dwEffect and DROPEFFECT_COPY <> 0) then dwEffect := DROPEFFECT_COPY
    else
  if (deMove in FOwner.FTargetEffectsSet) and (dwEffect and DROPEFFECT_MOVE<>0) then dwEffect := DROPEFFECT_MOVE
    else
  if (deLink in FOwner.FTargetEffectsSet) and (dwEffect and DROPEFFECT_LINK <> 0) then dwEffect := DROPEFFECT_LINK
    else dwEffect := DROPEFFECT_NONE;

  if FOwner.FTargetScrolling <> 0 then dwEffect := dwEffect or Integer(DROPEFFECT_SCROLL);
end;

procedure TDropTarget.AcceptDataObject(DataObj: IDataObject; var Accept:Boolean);
begin
  Accept := True;
end;

function TDropTarget.DragEnter(
  const dataObj: IDataObject; grfKeyState: LongInt; pt: TPoint; var dwEffect: LongInt): HResult;
// Is called if the d&d-mouse cursor moves ON (one call only) the TargeTWinControl. Here,
// you influence if a drop can be accepted and the drop's effect if accepted.
var
  FormatEtc: TFormatEtc;
  StgMedium: TStgMedium;
  Ptr: Pointer;
begin
  TDragDrop(FOwner).FInternalSource := GInternalSource;
  FOwner.FAvailableDropEffects := dwEffect;
  FOwner.FContextMenu := grfKeyState and MK_RBUTTON <> 0;
  if (FOwner.RenderDataOn = rdoEnter) or (FOwner.RenderDataOn = rdoEnterAndDropSync) or
     (FOwner.RenderDataOn = rdoEnterAndDropAsync) then
  begin
    RenderDropped(DataObj, grfKeyState, pt, dwEffect);
  end;

  FPreferredEffect := 0;
  with FormatEtc do
  begin
    cfFormat := CF_PREFERREDDROPEFFECT;
    ptd := nil;
    dwAspect := DVASPECT_CONTENT;
    lindex := -1;
    tymed := TYMED_HGLOBAL;
  end;
  if dataObj.GetData(FormatEtc, StgMedium) = S_OK then
  begin
    try
      if GlobalSize(StgMedium.HGlobal) = SizeOf(FPreferredEffect) then
      begin
        Ptr := GlobalLock(StgMedium.HGlobal);
        try
          FPreferredEffect := PLongInt(Ptr)^;
        finally
          GlobalUnLock(StgMedium.HGlobal);
        end;
      end;
    finally
      ReleaseStgMedium(StgMedium);
    end;
  end;

  SuggestDropEffect(grfKeyState, dwEffect);
  AcceptDataObject(DataObj, FAccept);
  if Assigned(FOwner.OnDragEnter) then
    FOwner.OnDragEnter(DataObj, grfKeyState, FOwner.FDragDropControl.ScreenToClient(pt), dwEffect, FAccept);
  if ((not FOwner.FAcceptOwnDnD) and FOwner.FOwnerIsSource) or
     (not FAccept) then
  begin
    dwEffect := DROPEFFECT_NONE;
  end;
  Result := NOERROR;
end;

function TDropTarget.DragOver(grfKeyState: LongInt; pt: TPoint; var dwEffect: LongInt): HResult;
// Is called if the mouse cursor moves OVER (called on every mouse move) the
// TargeTWinControl. Even here may you influence if a drop can be accepted and the
// drop's effect if accepted. Because this function is very often called YOUR
// function should be very efficient programmed.
var
  ScrollCode: Integer;
begin
  if FOwner.FScrollDetectOptions.FVertScrolling then
  begin
    DetermineScrollDir(True, ScrollCode);
    if ScrollCode > 0 then
    begin
      if ((not VertStartTimer.Enabled) and (not VertScrollTimer.Enabled)) or
         (FVScrollCode <> ScrollCode) then
      begin
        InitScroll(True, ScrollCode);
      end;
    end
      else
    if FVScrollCode <> 0 then TermScroll(True);
  end
    else
  if FVScrollCode <> 0 then TermScroll(True);

  if FOwner.FScrollDetectOptions.FHorzScrolling then
  begin
    DetermineScrollDir(False, ScrollCode);
    if ScrollCode > 0 then
    begin
      if ((not HorzStartTimer.Enabled) and (not HorzScrollTimer.Enabled)) or
         (FHScrollCode <> ScrollCode) then
      begin
        InitScroll(False, ScrollCode);
      end;
    end
      else
    if FHScrollCode <> 0 then TermScroll(False);
  end
    else
  if FHScrollCode <> 0 then TermScroll(False);

  if not FAccept then dwEffect := DROPEFFECT_NONE;
  SuggestDropEffect(grfKeyState, dwEffect);
  if Assigned(FOwner.OnDragOver) then
  begin
    FOwner.OnDragOver(grfKeyState, FOwner.FDragDropControl.ScreenToClient(pt), dwEffect, FPreferredEffect);
  end;
  if ((not FOwner.FAcceptOwnDnD) and FOwner.FOwnerIsSource) or
     (not FAccept) then
  begin
    dwEffect := DROPEFFECT_NONE;
  end;
  Result := NOERROR;
end;

function TDropTarget.DragLeave: HResult;
// Removes target feedback and releases the data object.
begin
  TDragDrop(FOwner).FInternalSource := nil;
  if Assigned(FOwner.OnDragLeave) then FOwner.OnDragLeave(0);
  FOwner.FAvailableDropEffects := 0;
  Result := NOERROR;
  TermScroll(True);
  TermScroll(False);
end;

function TDropTarget.Drop(const DataObj: IDataObject; grfKeyState: LongInt; pt: TPoint; var dwEffect: LongInt): HResult;
// Instructs drop target to handle the datas which are dropped on it.
var
  Menu: HMenu;
  Cmd: Cardinal;
  mcursor: TCursor;
  KeyState: Integer;

  function BuildMenuItemInfo(ACaption: string; ShowDefault: Boolean; ACommand: UInt; ASeparator: Boolean): TMenuItemInfo;
  begin
    with Result do
    begin
      // cbSize := SizeOf(MenuItemInfo);
      cbSize := 44; // Required for Windows 95
      fMask := MIIM_ID or MIIM_STATE or MIIM_TYPE;
      if ASeparator then fType := MFT_SEPARATOR
        else fType:=MFT_STRING;
      if ShowDefault then fState := MFS_ENABLED or MFS_Default
        else fState := MFS_ENABLED;
      wID := ACommand;
      hSubMenu := 0;
      hbmpChecked := 0;
      hbmpUnchecked := 0;
      dwTypeData := PChar(ACaption);
    end;
  end;

begin
  Result := E_Fail;
  if FOwner.FContextMenu then KeyState := grfKeyState or MK_RBUTTON
    else KeyState := grfKeyState or MK_LButton;
  if FAccept then SuggestDropEffect(KeyState, dwEffect)
    else dwEffect := DROPEFFECT_NONE;
  if Assigned(FOwner.OnDragOver) then
  begin
    FOwner.OnDragOver(KeyState, FOwner.FDragDropControl.ScreenToClient(pt), dwEffect, FPreferredEffect);
  end;
  if ((not FOwner.FAcceptOwnDnD) and FOwner.FOwnerIsSource) or (not FAccept) then dwEffect := DROPEFFECT_NONE;
  TermScroll(True);
  TermScroll(False);
  if not FOwner.DropHandler(DataObj, KeyState, pt, dwEffect) then
  begin
    // Show popup menu?
    if FOwner.FContextMenu and FOwner.FShowPopupMenu and (dwEffect <> DROPEFFECT_NONE) then
    begin
      Menu := CreatePopupMenu;
      if (deMove in FOwner.FTargetEffectsSet) and (FOwner.FAvailableDropEffects and DROPEFFECT_MOVE <> 0) then
      begin
        InsertMenuItem(
          Menu, DWORD(-1), True, BuildMenuItemInfo(MIMoveStr, dwEffect and DROPEFFECT_MOVE<>0, CmdMove, False));
      end;
      if (deCopy in FOwner.FTargetEffectsSet) and (FOwner.FAvailableDropEffects and DROPEFFECT_COPY <> 0) then
      begin
        InsertMenuItem(
          Menu, DWORD(-1), True, BuildMenuItemInfo(MICopyStr, dwEffect and DROPEFFECT_COPY <> 0, CmdCopy, False));
      end;
      if (deLink in FOwner.FTargetEffectsSet) and (FOwner.FAvailableDropEffects and DROPEFFECT_LINK <> 0) then
      begin
        InsertMenuItem(
          Menu, DWORD(-1), True, BuildMenuItemInfo(MILinkStr, dwEffect and DROPEFFECT_LINK <> 0, CmdLink, False));
      end;
      InsertMenuItem(Menu, DWORD(-1), True, BuildMenuItemInfo('-', False, CmdSeparator, True));
      InsertMenuItem(Menu, DWORD(-1), True, BuildMenuItemInfo(MIAbortStr, False, CmdAbort, False));
      // Add custom-menuitems ...
      FOwner.DoMenuPopup(Self, Menu, DataObj, MinCustCmd, KeyState, pt);
      try
        dwEffect := DROPEFFECT_NONE;
        Cmd := Cardinal(TrackPopupMenuEx(Menu, TPM_LEFTALIGN or TPM_RIGHTBUTTON or TPM_RETURNCMD, pt.x, pt.y, FOwner.DragDropControl.Handle, nil));
        case Cmd of
          CmdMove: dwEffect := DROPEFFECT_MOVE;
          CmdCopy: dwEffect := DROPEFFECT_COPY;
          CmdLink: dwEffect := DROPEFFECT_LINK;
          CmdSeparator, CmdAbort: dwEffect := DROPEFFECT_NONE;
          else // custom-menuitem was selected ...
            begin
              dwEffect := DROPEFFECT_NONE;
              if FOwner.DoMenuExecCmd(Self, Menu, DataObj, Cmd, dwEffect) and
                 Assigned(FOwner.FOnMenuSucceeded) then
              begin
                FOwner.FOnMenuSucceeded(Self, KeyState, FOwner.FDragDropControl.ScreenToClient(pt), dwEffect);
              end;
            end;
        end;
      finally
        FOwner.DoMenuDestroy(Self, Menu);
        DestroyMenu(Menu);
      end;
    end;
    if Assigned(FOwner.OnDrop) then
    begin
      FOwner.OnDrop(DataObj, KeyState, FOwner.FDragDropControl.ScreenToClient(pt), dwEffect);
    end;
    if dwEffect <> DROPEFFECT_NONE then
    begin
      if FOwner.FBTF then SetForegroundWindow(GetParentForm(FOwner.Owner as TWinControl).Handle);
      TDragDrop(FOwner).FdwEffect := dwEffect;
      TDragDrop(FOwner).FgrfKeyState := KeyState;
      TDragDrop(FOwner).Fpt := pt;
      if (FOwner.RenderDataOn = rdoDropAsync) or
         (FOwner.RenderDataOn = rdoEnterAndDropAsync) then
      begin
        TDragDrop(FOwner).FDataObj := DataObj;
        DataObj._AddRef;
      end
        else
      if (FOwner.RenderDataOn = rdoDropSync) or (FOwner.RenderDataOn = rdoEnterAndDropSync) then
      begin
        // Set hourglass-cursor
        mcursor := Screen.Cursor;
        Screen.Cursor := crHourGlass;
        try
          RenderDropped(DataObj, KeyState, pt, dwEffect);
        finally
          // Set old cursor
          Screen.Cursor := mcursor;
        end;
      end;
      PostMessage(FOwner.DragDropControl.Handle, DDM_ProcessDropped, 0, 0);
      Result := NOERROR;
    end
      else TDragDrop(FOwner).FInternalSource := nil;
  end
    else
  begin
    TDragDrop(FOwner).FInternalSource := nil;
    if Assigned(FOwner.FOnDropHandlerSucceeded) then
    begin
      FOwner.FOnDropHandlerSucceeded(Self, KeyState, FOwner.FDragDropControl.ScreenToClient(pt), dwEffect);
    end;
  end;
end;

procedure TDropTarget.RenderDropped(DataObj: IDataObject; grfKeyState: LongInt; pt: TPoint; var dwEffect: LongInt);
begin
  // override, if you need ...
end;

// TScrollDetectArea methods ---------------------------------------------------

constructor TScrollDetectArea.Create(Control: TPersistent);
begin
  inherited Create;
  FControl := Control;
end;

procedure TScrollDetectArea.AssignTo(Dest: TPersistent);
begin
  if Dest is TScrollDetectArea then
  begin
    with TScrollDetectArea(Dest) do
    begin
      FMargin := Self.FMargin;
      FRange := Self.FRange;
      Change;
    end;
  end
    else
  inherited AssignTo(Dest);
end;

procedure TScrollDetectArea.SetValue(Index: Integer; Value: Word);
begin
  case Index of
    0: if Value <> FMargin then
       begin
         FMargin := Value;
         Change;
       end;
    1: if Value <> FRange then
       begin
         FRange:=Value;
         Change;
       end;
  end;
end;

procedure TScrollDetectArea.Change;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

// TScrollDetectOptions methods -------------------------------------------------

constructor TScrollDetectOptions.Create(Control: TDragDrop);
begin
  inherited Create;
  FControl := Control;
  FScrollDelay := 100;
  FStartDelay := 750;
  FLeft := TScrollDetectArea.Create(self);
  FLeft.Margin := 0;
  FLeft.Range := 10;
  FLeft.OnChange := FOnChange;
  FTop := TScrollDetectArea.Create(self);
  FTop.Margin := 0;
  FTop.Range := 10;
  FTop.OnChange := FOnChange;
  FRight := TScrollDetectArea.Create(self);
  FRight.Margin := 0;
  FRight.Range := 10;
  FRight.OnChange := FOnChange;
  FBottom := TScrollDetectArea.Create(self);
  FBottom.Margin := 0;
  FBottom.Range := 10;
  FBottom.OnChange := FOnChange;
  FHorzScrolling := False;
  FVertScrolling := False;
  FHorzPageScroll := False;
  FVertPageScroll := False;
end;

destructor TScrollDetectOptions.Destroy;
begin
  FLeft.Free;
  FTop.Free;
  FRight.Free;
  FBottom.Free;
  inherited;
end;

procedure TScrollDetectOptions.AssignTo(Dest: TPersistent);
begin
  if Dest is TScrollDetectOptions then
  begin
    with TScrollDetectOptions(Dest) do
    begin
      FScrollDelay := Self.FScrollDelay;
      FStartDelay := Self.FStartDelay;
      FLeft.AssignTo(Self.FLeft);
      FTop.AssignTo(Self.FTop);
      FRight.AssignTo(Self.FRight);
      FBottom.AssignTo(Self.FBottom);
      Change;
    end;
  end
    else
  inherited AssignTo(Dest);
end;

procedure TScrollDetectOptions.SetValue(index: Integer; Value: TScrollInterval);
begin
  if (Index = 0) and (Value <> FScrollDelay) then
  begin
    FScrollDelay := Value;
    Change;
  end;
  if (Index = 1) and (Value <> FStartDelay) then
  begin
    FStartDelay := Value;
    Change;
  end;
end;

procedure TScrollDetectOptions.Change;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

// TDragDrop control ------------------------------------------------------

constructor TDragDrop.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDropTarget := TDropTarget.Create(Self);
  FRegistered := False;
  FDragDropControl := nil;
  FBTF := False;
  FAcceptOwnDnD := False;
  FShowPopupMenu := True;
  FDragDetectDelta := 10;
  FDragDetectStatus := ddsNone;
  FRenderDataOn := rdoDropSync;
  FCHCopy := DefaultCursor;
  FCHMove := DefaultCursor;
  FCHLink := DefaultCursor;
  FCHScrollCopy := DefaultCursor;
  FCHScrollMove := DefaultCursor;
  FCHScrollLink := DefaultCursor;
  FMessageHooked := False;
  FAvailableDropEffects := 0;
  FTargetScrolling := 0;
  FSrcCompatibilityCheck := [CheckLindex, CheckdwAspect];
  FScrollDetectOptions := TScrollDetectOptions.Create(Self);
  FInternalSource := nil;
end;

destructor TDragDrop.Destroy;
begin
  UnregisterTarget;
  UnhookMessageHandler(True);
  FDropTarget._Release;
  FDropTarget := nil;
  FDragDropControl := nil;
  FScrollDetectOptions.Free;
  inherited;
end;

procedure TDragDrop.WndMethod(var Msg: TMessage); // message-hook to receive DDM_ProcessDropped
var
  mcursor: TCursor;
begin
  with Msg do
  begin
    Result := CallWindowProc(OldWndProc, DragDropControl.Handle, Msg, wParam, LParam);
    if Msg = DDM_ProcessDropped then
    begin
      if (RenderDataOn = rdoDropAsync) or (RenderDataOn = rdoEnterAndDropAsync) then
      begin
        // Set hourglass-cursor
        mcursor := Screen.Cursor;
        Screen.Cursor := crHourGlass;
        try
          FDropTarget.RenderDropped(FDataObj, FgrfKeyState, Fpt, FdwEffect);
          FDataObj._Release;
        finally
          // Set old cursor
          Screen.Cursor := mcursor;
        end;
      end;
      if Assigned(FOnProcessDropped) then
      begin
        FOnProcessDropped(Self, FgrfKeyState, FDragDropControl.ScreenToClient(Fpt), FdwEffect);
      end;
      FAvailableDropEffects := 0;
      FInternalSource := nil;
    end;
    case Msg of
      WM_DESTROY:
        begin
          if FRegistered then
          begin
            CoLockObjectExternal(FDropTarget, False, False);
            if (not FDragDropControl.HandleAllocated) or
               (FDragDropControl.HandleAllocated and
               (RevokeDragDrop(FDragDropControl.Handle) = S_OK)) then
            begin
              FRegistered:=False;
            end;
          end;
          FMessageHooked := False;
        end;
      WM_LBUTTONDOWN, WM_RBUTTONDOWN:
        begin
          if FAutoDetectDnD and (FDragDetectStatus = ddsNone) and
             (FSourceEffects <> 0) then
          begin
            if Msg = WM_LBUTTONDOWN then FDragDetectStatus := ddsLeft
              else FDragDetectStatus := ddsRight;
            GetCursorPos(FDragDetectStart);
            if Assigned(FOnDragDetect) then
            begin
               FOnDragDetect(wparam,
                 FDragDropControl.ScreenToClient(FDragDetectStart),
                 FDragDropControl.ScreenToClient(FDragDetectStart),
                 FDragDetectStatus);
            end;
            if MouseHookHandle <> 0 then
            begin // MouseHookProc is used by another component ...
              UnHookWindowsHookEx(MouseHookHandle);
              MouseHookHandle := 0;
              if Assigned(MouseHookDragDrop) then
              begin
                MouseHookDragDrop.FDragDetectStatus := ddsNone;
                if Assigned(MouseHookDragDrop.FOnDragDetect) then
                begin
                  MouseHookDragDrop.FOnDragDetect(
                    wparam,
                    MouseHookDragDrop.FDragDropControl.ScreenToClient(MouseHookDragDrop.FDragDetectStart),
                    MouseHookDragDrop.FDragDropControl.ScreenToClient(FDragDetectStart),
                    MouseHookDragDrop.FDragDetectStatus);
                end;
              end;
            end;
            MouseHookDragDrop := Self;
            MouseHookHandle := SetWindowsHookEx(WH_MOUSE, MouseHookProc, LongWord(HInstance), 0);
          end;
        end;
      WM_HSCROLL:
        if LOWORD(wParam) <> SB_ENDSCROLL then FTargetScrolling := FTargetScrolling or 1
          else FTargetScrolling := FTargetScrolling and not 1;
      WM_VSCROLL:
        begin
          if LOWORD(wParam) <> SB_ENDSCROLL then FTargetScrolling := FTargetScrolling or 2
            else FTargetScrolling := FTargetScrolling and not 2;
        end;
      WM_MOUSEMOVE:
        if (MouseHookHandle <> 0) and (wParam and (MK_LBUTTON or MK_RBUTTON) = 0) then
        begin
          UnHookWindowsHookEx(MouseHookHandle);
          MouseHookHandle := 0;
          if Assigned(MouseHookDragDrop) then
          begin
            MouseHookDragDrop.FDragDetectStatus := ddsNone;
            if Assigned(MouseHookDragDrop.FOnDragDetect) then
            begin
              MouseHookDragDrop.FOnDragDetect(wparam,
                MouseHookDragDrop.FDragDropControl.ScreenToClient(MouseHookDragDrop.FDragDetectStart),
                MouseHookDragDrop.FDragDropControl.ScreenToClient(FDragDetectStart),
                MouseHookDragDrop.FDragDetectStatus);
            end;
          end;
          MouseHookDragDrop := nil;
        end;
    end;
  end;
end;

procedure TDragDrop.StartDnDDetection(Button: TMouseButton);
var
  grfKeyState: LongInt;
begin
  if Button = mbLeft then FDragDetectStatus := ddsLeft
    else
  if Button = mbRight then FDragDetectStatus := ddsRight
    else
  begin
    FDragDetectStatus := ddsNone;
  end;
  if FDragDetectStatus <> ddsNone then
  begin
    GetCursorPos(FDragDetectStart);
    if HiWord(DWord(GetKeyState(VK_SHIFT))) <> 0 then grfKeyState := MK_SHIFT
      else grfKeyState := 0;
    if HiWord(DWord(GetKeyState(VK_CONTROL))) <> 0 then
       grfKeyState := grfKeyState or MK_CONTROL;
    if MouseHookHandle <> 0 then
    begin // MouseHookProc is used by another component ...
      UnHookWindowsHookEx(MouseHookHandle);
      MouseHookHandle := 0;
      if Assigned(MouseHookDragDrop) then
      begin
        MouseHookDragDrop.FDragDetectStatus := ddsNone;
        if Assigned(MouseHookDragDrop.FOnDragDetect) then
        begin
          MouseHookDragDrop.FOnDragDetect(grfKeyState,
            MouseHookDragDrop.FDragDropControl.ScreenToClient(MouseHookDragDrop.FDragDetectStart),
            MouseHookDragDrop.FDragDropControl.ScreenToClient(FDragDetectStart),
            MouseHookDragDrop.FDragDetectStatus);
        end;
      end;
    end;
    MouseHookDragDrop := Self;
    MouseHookHandle := SetWindowsHookEx(WH_MOUSE, MouseHookProc, LongWord(HInstance), 0);
    if Assigned(FOnDragDetect) then
    begin
      FOnDragDetect(grfKeyState,
         FDragDropControl.ScreenToClient(FDragDetectStart),
         FDragDropControl.ScreenToClient(FDragDetectStart),
         FDragDetectStatus);
    end;
  end;
end;

procedure TDragDrop.Loaded;
// Methode which is called if all components are created - now, we can register
// the target control for drag-and-drop operations
begin
  inherited Loaded;
  if (FDragDropControl <> nil) and not (csDesigning in ComponentState) then RegisterTarget;
end;

procedure TDragDrop.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (AComponent = FDragDropControl) and (Operation = opRemove) then
  begin
    UnregisterTarget;
    UnhookMessageHandler(True);
    FDragDropControl := nil;
  end;
end;

function TDragDrop.RegisterTarget: Boolean;
// Methode for registering the DragDropControl for drag-and-drop oprations
begin
  Result := False;
  try
    HookMessageHandler;
  finally
    // nothing to do
  end;
  if (not FRegistered) and (FTargetEffects <> 0) and (FDragDropControl <> nil) then
  begin
    try
      // CoLockObjectExternal crashes debugging intermittently in C++Builder 2010
      {$IFNDEF IDE}
      // Ensure that drag-and-drop interface stays in memory
      CoLockObjectExternal(FDropTarget, True, False);
      {$ENDIF}
      if RegisterDragDrop(FDragDropControl.Handle, IDropTarget(FDropTarget)) = S_OK then
      begin
        Result := True;
        FRegistered := True;
      end;
    except
      Result:=False;
      FRegistered:=False;
    end;
  end;
end;

function TDragDrop.UnRegisterTarget: Boolean;
begin
  Result := False;
  if FRegistered and (FDragDropControl <> nil) then
  begin
    try
      UnHookMessageHandler(False);
      CoLockObjectExternal(FDropTarget, False, False);
      if (not FDragDropControl.HandleAllocated) or
         (FDragDropControl.HandleAllocated and (RevokeDragDrop(FDragDropControl.Handle) = S_OK)) then
      begin
        FRegistered := False;
        Result := True;
      end;
    except
    end;
  end;
end;

procedure TDragDrop.HookMessageHandler;
begin
  if (FDragDropControl <> nil) and (FDragDropControl.Handle <> 0) and
     (not FMessageHooked) and ((FSourceEffects <> 0) or (FTargetEffects <> 0)) then
  begin
    WndProcPtr := MakeObjectInstance(WndMethod);
    OldWndProc := Pointer(SetWindowLong(FDragDropControl.Handle, GWL_WNDPROC, LongInt(WndProcPtr)));
    FMessageHooked := True;
  end;
end;

procedure TDragDrop.UnhookMessageHandler(ForceUnhook: Boolean);
begin
  if FMessageHooked and (ForceUnhook or ((FSourceEffects=0) and (FTargetEffects=0))) then
  begin
    SetWindowLong(FDragDropControl.Handle, GWL_WNDPROC, LongInt(OldWndProc));
    FreeObjectInstance(WndProcPtr);
    WndProcPtr := nil;
    OldWndProc := nil;
    FMessageHooked := False;
  end;
end;

procedure TDragDrop.DoMenuPopup(
  Sender: TObject; AMenu: HMenu; DataObj: IDataObject; AMinCustCmd:Integer; grfKeyState: LongInt; pt: TPoint);
begin
  if Assigned(FOnMenuPopup) then
  begin
    FOnMenuPopup(Sender, AMenu, DataObj, AMinCustCmd, grfKeyState, FDragDropControl.ScreenToClient(pt));
  end;
end;

function TDragDrop.DoMenuExecCmd(
  Sender: TObject; AMenu: HMenu; DataObj: IDataObject; Command: Integer; var dwEffect: LongInt): Boolean;
begin
  Result := False;
  if Assigned(FOnMenuExecCmd) then
  begin
    FOnMenuExecCmd(Sender, AMenu, DataObj, Command, dwEffect, Result);
  end;
end;

procedure TDragDrop.DoMenuDestroy(Sender:TObject; AMenu: HMenu);
begin
  if Assigned(FOnMenuDestroy) then FOnMenuDestroy(Sender, AMenu);
end;

procedure TDragDrop.SetDragDropControl(WinControl: TWinControl);
begin
  if WinControl <> FDragDropControl then
  begin
    if FRegistered and not (csDesigning in ComponentState) then
    begin
      UnhookMessageHandler(True);
      UnregisterTarget;
    end;
    FDragDropControl := WinControl;
    if not (csDesigning in ComponentState) then RegisterTarget;
  end;
end;

function TDragDrop.ExecuteOperation(DataObject: TDataObject): TDragResult;
var
  dwEffect: LongInt;
  DropSource: TDropSource;
  pt: TPoint;
  grfKeyState: LongInt;
  DragResult: HResult;
begin
  Result := drInvalid;
  if (DataObject = nil) or (DragDropControl = nil) or (GInternalSource <> nil) then exit;
  GInternalSource := Self;
  if FSourceEffects <> 0 then
  begin
    if MouseHookHandle <> 0 then
    begin
      UnHookWindowsHookEx(MouseHookHandle);
      MouseHookHandle := 0;
    end;
    FDragDetectStatus := ddsDrag;
    DataObject.FCheckLindex := CheckLindex in FSrcCompatibilityCheck;
    DataObject.FCheckdwAspect := CheckdwAspect in FSrcCompatibilityCheck;
    try
      FOwnerIsSource := True;
      try
        DropSource := TDropSource.Create(self);
        try
          DragResult := DoDragDrop(IDataObject(DataObject), DropSource, FSourceEffects, dwEffect);
          if DragResult = DRAGDROP_S_DROP then
          begin
            case dwEffect and ((DROPEFFECT_COPY or DROPEFFECT_MOVE or DROPEFFECT_LINK)) of
              DROPEFFECT_COPY: Result := drCopy;
              DROPEFFECT_MOVE: Result := drMove;
              DROPEFFECT_LINK: Result := drLink;
              else
                begin
                  { dropped on no-drop location }
                  Result := drInvalid;
                end;
            end;
          end
            else
          begin
            { cancelled by user }
            Result := drCancelled;
          end;
        finally
          DropSource._Release;
        end;
      except
        raise;
      end;
    finally
      FOwnerIsSource := False;
      DataObject._Release;
    end;
    FDragDetectStatus := ddsNone;
    if Assigned(FOnDragDetect) then
    begin
      GetCursorPos(pt);
      if HiWord(DWord(GetKeyState(VK_SHIFT))) <> 0 then grfKeyState := MK_SHIFT
        else grfKeyState := 0;
      if HiWord(DWord(GetKeyState(VK_CONTROL))) <> 0 then grfKeyState := grfKeyState or MK_CONTROL;
      FOnDragDetect(grfKeyState,
        FDragDropControl.ScreenToClient(FDragDetectStart),
        FDragDropControl.ScreenToClient(pt), FDragDetectStatus);
    end;
  end
    else
  begin
    FDragDetectStatus := ddsNone;
    Result := drCancelled;
  end;
  GInternalSource := nil;
end;

function TDragDrop.Execute: TDragResult;
begin
  Result := ExecuteOperation(CreateDataObject);
end;

procedure TDragDrop.SetSourceEffects(Values: TDropEffectSet);
begin
  FSourceEffectsSet := Values;
  FSourceEffects := 0;
  if deCopy in Values then Inc(FSourceEffects, DROPEFFECT_COPY);
  if deMove in Values then Inc(FSourceEffects, DROPEFFECT_MOVE);
  if deLink in Values then Inc(FSourceEffects, DROPEFFECT_LINK);
  if (not (csDesigning in ComponentState)) and (not (csLoading in ComponentState)) then
  begin
    if (not FMessageHooked) and (FSourceEffects <> 0) then HookMessageHandler;
    if FMessageHooked and (FSourceEffects = 0) then UnhookMessageHandler(False);
  end;
end;

procedure TDragDrop.SetTargetEffects(Values:TDropEffectSet);
begin
  FTargetEffectsSet := Values;
  FTargetEffects := 0;
  if deCopy in Values then Inc(FTargetEffects, DROPEFFECT_COPY);
  if deMove in Values then Inc(FTargetEffects, DROPEFFECT_MOVE);
  if deLink in Values then Inc(FTargetEffects, DROPEFFECT_LINK);
  if (not (csDesigning in ComponentState)) and (not FRegistered) and (FTargetEffects <> 0) then RegisterTarget;
  if FRegistered and (FTargetEffects = 0) then UnRegisterTarget;
end;

function TDragDrop.CopyToClipboard: Boolean;
var
  DataObject:IDataObject;
begin
  Result := False;
  DataObject := CreateDataObject;
  if DataObject <> nil then
  begin
    try
      Result := (OLESetClipBoard(DataObject) = S_OK);
    finally
      DataObject._Release;
    end;
  end;
end;

function TDragDrop.GetFromClipboard: Boolean;
var
  DataObject: IDataObject;
  pt: TPoint;
  dwEffect: LongInt;
begin
  Result := (OLEGetClipBoard(DataObject) = S_OK);
  if Result then
  begin
    pt.x := -1;
    pt.y := -1;
    dwEffect := DROPEFFECT_COPY;
    FDropTarget.RenderDropped(DataObject, 0, pt, dwEffect);
  end;
end;

function TDragDrop.DropHandler(const dataObj: IDataObject; grfKeyState: LongInt; pt: TPoint; var dwEffect: LongInt): Boolean;
begin
  Result := False;
end;

// Register method -------------------------------------------------------------

procedure Register;
begin
  RegisterComponents('DragDrop', [TDragDrop]);
end;

// initialize/de-initialize the ole libary -------------------------------------

initialization
  OleInitialize(nil);
  MouseHookHandle := 0;
  GInternalSource := nil;
  // to avoid mix ups
  DDM_ProcessDropped := RegisterWindowMessage('DDM_ProcessDropped');

finalization
  if MouseHookHandle <> 0 then UnHookWindowsHookEx(MouseHookHandle);
  OleUninitialize;

end.