{ *************************************************************************** }
{                                                                             }
{ EControl Common Library                                                     }
{                                                                             }
{ Copyright (c) 2004 - 2006 EControl Ltd., Zaharov Michael                    }
{     www.econtrol.ru                                                         }
{     support@econtrol.ru                                                     }
{                                                                             }
{ *************************************************************************** }
{$I ecSyntEdit.INC}

unit ecOleDrag;

interface

uses {$IFDEF EC_DOTNET}System.Runtime.InteropServices, {$ENDIF}
     Classes, Windows, ActiveX, Controls, ecStrUtils, Graphics;

(*$HPPEMIT '' *)
(*$HPPEMIT '#include <olectl.h>' *)
(*$HPPEMIT '#include <docobj.H>' *)
(*$HPPEMIT '#include <oleauto.h>' *)
(*$HPPEMIT '#include <propidl.h>' *) // WIN2K
(*$HPPEMIT '' *)
(*$HPPEMIT '' *)

  {$IFDEF EC_VCL8}
      type
        [ComImport,
        GuidAttribute('00000103-0000-0000-C000-000000000046'),
        InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown)]
        IEnumFORMATETC = interface
          [PreserveSig]
          function Next(celt: ULONG;
            [out, MarshalAs(UnmanagedType.LPArray, SizeParamIndex = 0)]
            rgelt: array of TFormatEtc; out pceltFetched: ULONG): HResult;
          [PreserveSig]
          function Skip(celt: Longint): HResult;
          [PreserveSig]
          function Reset: HResult;
          [PreserveSig]
          function Clone(out Enum: IEnumFormatEtc): HResult;
        end;

      { IDataObject interface }

        [ComImport,
        GuidAttribute('0000010E-0000-0000-C000-000000000046'),
        InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown)]
        IDataObject = interface
          [PreserveSig]
          function GetData([in] var formatetcIn: TFormatEtc; out medium: TStgMedium): HResult;
          [PreserveSig]
          function GetDataHere([in] var formatetc: TFormatEtc; out medium: TStgMedium): HResult;
          [PreserveSig]
          function QueryGetData([in] var formatetc: TFormatEtc): HResult;
          [PreserveSig]
          function GetCanonicalFormatEtc([in] var formatetc: TFormatEtc;
            out formatetcOut: TFormatEtc): HResult;
          [PreserveSig]
          function SetData([in] var formatetc: TFormatEtc; var medium: TStgMedium;
            fRelease: BOOL): HResult;
          [PreserveSig]
          function EnumFormatEtc(dwDirection: Longint; out enumFormatEtc: IEnumFormatEtc): HResult;
          [PreserveSig]
          function DAdvise([in] var formatetc: TFormatEtc; advf: Longint;
            [in] var advSink: IAdviseSink; out dwConnection: Longint): HResult;
          [PreserveSig]
          function DUnadvise(dwConnection: Longint): HResult;
          [PreserveSig]
          function EnumDAdvise(out enumAdvise: IEnumStatData): HResult;
        end;

      { IDropTarget interface }
        [ComImport,
        GuidAttribute('00000122-0000-0000-C000-000000000046'),
        InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown)]
        IDropTarget = interface
          [PreserveSig]
          function DragEnter([in, MarshalAs(UnmanagedType.Interface)] dataObj: IDataObject;
            grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;
          [PreserveSig]
          function DragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;
          [PreserveSig]
          function DragLeave: HResult;
          [PreserveSig]
          function Drop([in, MarshalAs(UnmanagedType.Interface)] dataObj: IDataObject;
            grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;
        end;

      { IDropSource interface }

        [ComImport,
        GuidAttribute('00000121-0000-0000-C000-000000000046'),
        InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown)]
        IDropSource = interface
          [PreserveSig]
          function QueryContinueDrag(fEscapePressed: BOOL;
            grfKeyState: Longint): HResult;
          [PreserveSig]
          function GiveFeedback(dwEffect: Longint): HResult;
        end;

      const
        DATADIR_GET = 1;
        DATADIR_SET = 2;
        DVASPECT_CONTENT   = 1;
        TYMED_HGLOBAL  = 1;
  {$ENDIF}
type

  TecOleDragEvent = procedure(Sender: TObject; const DataObject: IDataObject;
       KeyState: Integer; Pt: TPoint; var Effect: Integer; var Handled: Boolean) of object;
  TecOleGiveFeedback = procedure(Sender: TObject; dwEffect: Integer; var Handled: Boolean) of object;

  TecOLEAnsiText = procedure(Sender: TObject; pt: TPoint; const Text: string) of object;
  TecOLEUnicodeText = procedure(Sender: TObject; pt: TPoint; const Text: WideString) of object;

  TecDragDrop = class(TComponent, IDropTarget)
  private
    FWndHandle: HWND;
    FActive: Boolean;
    FControl: TWinControl;
    FOnOleDrop: TecOleDragEvent;
    FOnOleDragOver: TecOleDragEvent;
    FOnOleDragEnter: TecOleDragEvent;
    FDataObj: IDataObject;
    FOnSetAnsiText: TecOLEAnsiText;
    FOnSetUnicodeText: TecOLEUnicodeText;
    function GetActive: Boolean;
    procedure SetActive(const Value: Boolean);
    procedure SetControl(const Value: TWinControl);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation);
      override;
    procedure Loaded; override;
    function InternalHandled(const DataObject: IDataObject): Boolean;
    // IDropTarget
    {$IFDEF EC_DOTNET}
    function DragEnter(DataObject: IDataObject; KeyState: Longint; pt: TPoint; var Effect: Longint): HResult; virtual;
    function DragOver(KeyState: Longint; pt: TPoint; var Effect: Longint): HResult; virtual;
    function DragLeave: HResult; virtual;
    function Drop(DataObject: IDataObject; KeyState: Longint; pt: TPoint; var Effect: Longint): HResult; virtual;
    {$ELSE}
    function DragEnter(const DataObject: IDataObject; KeyState: Longint; Pt: TPoint; var Effect: Longint): HResult; virtual; stdcall;
    function DragLeave: HResult; virtual; stdcall;
    function DragOver(KeyState: Longint; Pt: TPoint; var Effect: Longint): HResult; virtual; stdcall;
    function Drop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; var Effect: Longint): HResult; virtual; stdcall;
    {$ENDIF}
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Active: Boolean read GetActive write SetActive;
  published
    property Control: TWinControl read FControl write SetControl;
    property OnOleDragEnter: TecOleDragEvent read FOnOleDragEnter write FOnOleDragEnter;
    property OnOleDragOver: TecOleDragEvent read FOnOleDragOver write FOnOleDragOver;
    property OnOleDrop: TecOleDragEvent read FOnOleDrop write FOnOleDrop;
    property OnSetAnsiText: TecOLEAnsiText read FOnSetAnsiText write FOnSetAnsiText;
    property OnSetUnicodeText: TecOLEUnicodeText read FOnSetUnicodeText write FOnSetUnicodeText;
  end;

  TecDataObject = class(TInterfacedObject, IDataObject, IEnumFORMATETC)
  private
    FIndex: integer;
    FData: TList;
  private
    // IEnumFORMATETC
    {$IFDEF EC_DOTNET}
    function Next(celt: ULONG; rgelt: array of TFormatEtc; out pceltFetched: ULONG): HResult;
    function Skip(celt: Longint): HResult;
    function Reset: HResult;
    function Clone(out Enum: IEnumFormatEtc): HResult;
    {$ELSE}
    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;
    {$ENDIF}
    // IDataObject
    {$IFDEF EC_DOTNET}
    function GetData(var formatetcIn: TFormatEtc; out medium: TStgMedium): HResult;
    function GetDataHere(var formatetc: TFormatEtc; out medium: TStgMedium): HResult;
    function QueryGetData(var formatetc: TFormatEtc): HResult;
    function GetCanonicalFormatEtc(var formatetc: TFormatEtc; out formatetcOut: TFormatEtc): HResult;
    function SetData(var formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult;
    function EnumFormatEtc(dwDirection: Longint; out enumFormatEtc: IEnumFormatEtc): HResult;
    function DAdvise(var formatetc: TFormatEtc; advf: Longint; var advSink: IAdviseSink; out dwConnection: Longint): HResult;
    function DUnadvise(dwConnection: Longint): HResult;
    function EnumDAdvise(out enumAdvise: IEnumStatData): HResult;
    {$ELSE}
    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;
    {$ENDIF}
  public
    constructor Create;
    destructor Destroy; override;

    procedure SetFormatData(Format: Word; {$IFDEF EC_DOTNET}Buffer: TBytes; {$ELSE}var Buffer; {$ENDIF}Count: integer);
  end;

function GetFormatInfo(const DataObj: IDataObject; AFormat: TClipFormat): Boolean; overload;
function GetFormatInfo(const DataObj: IDataObject; AFormat: TClipFormat; var pFormatInfo: TFormatEtc): Boolean; overload;

function GetDragText(const DataObj: IDataObject; CharSet: TFontCharset = DEFAULT_CHARSET): ecString;

{$IFDEF EC_VCL8}
function RegisterDragDrop(wnd: HWnd; dropTarget: IDropTarget): HResult;
function RevokeDragDrop(wnd: HWnd): HResult;
function DoDragDrop(dataObj: IDataObject; dropSource: IDropSource;
  dwOKEffects: Longint; var dwEffect: Longint): HResult;
procedure ReleaseStgMedium(var medium: TStgMedium);
{$ENDIF}

implementation

uses Contnrs, Forms;

{$IFDEF EC_VCL8}
const
  ole32    = 'ole32.dll';

[DllImport(Ole32, CharSet = CharSet.Unicode, EntryPoint = 'RegisterDragDrop')]
function RegisterDragDrop; external;
[DllImport(Ole32, CharSet = CharSet.Unicode, EntryPoint = 'RevokeDragDrop')]
function RevokeDragDrop; external;
[DllImport(Ole32, CharSet = CharSet.Unicode, EntryPoint = 'DoDragDrop')]
function DoDragDrop; external;
[DllImport(ole32, CharSet = CharSet.Unicode, EntryPoint = 'ReleaseStgMedium')]
procedure ReleaseStgMedium; external;
{$ENDIF}

type
  TDataHolder = class
    Format: Word;
    Data: array of byte;
  end;

function GetFormatInfo(const DataObj: IDataObject; AFormat: TClipFormat): Boolean;
var FI: TFormatEtc;
begin
  Result := GetFormatInfo(DataObj, AFormat, FI);
end;

function GetFormatInfo(const DataObj: IDataObject; AFormat: TClipFormat; var pFormatInfo: TFormatEtc): Boolean;
var FEnum: IEnumFormatEtc;
{$IFDEF EC_DOTNET}
    celtFetched: Cardinal;
    pFI: array[0..0] of TFormatEtc;
{$ELSE}
    celtFetched: LongInt;
{$ENDIF}
begin
  Result := False;
  FEnum := nil;
  DataObj.EnumFormatEtc(DATADIR_GET, FEnum);
  if FEnum <> nil then
   begin
    FEnum.Reset;
    {$IFDEF EC_DOTNET}
    while FEnum.Next(1, pFI, celtFetched) = S_OK do
      if pFI[0].cfFormat = AFormat then
        begin
          pFormatInfo := pFI[0];
    {$ELSE}
    while FEnum.Next(1, pFormatInfo, @celtFetched) = S_OK do
      if pFormatInfo.cfFormat = AFormat then
        begin
    {$ENDIF}
         Result := True;
         Exit;
        end;
   end;
end;

function GetDragText(const DataObj: IDataObject; CharSet: TFontCharset): ecString;
var Medium : TStgMedium;
    FFormat: TFormatEtc;
begin
  Result := '';
  if (GetFormatInfo(DataObj, {$IFNDEF EC_UNICODE}CF_TEXT{$ELSE}CF_UNICODETEXT{$ENDIF}, FFormat) or
      GetFormatInfo(DataObj, {$IFDEF EC_UNICODE}CF_TEXT{$ELSE}CF_UNICODETEXT{$ENDIF}, FFormat)) and
      Succeeded(DataObj.GetData(FFormat, Medium)) then
    try
      if Medium.hGlobal <> 0 then
        Result := StringFromHandle(Medium.hGlobal, FFormat.cfFormat, Charset);
    finally
//      ReleaseStgMedium(Medium);
    end;
end;

{ TecDataObject }

constructor TecDataObject.Create;
begin
  inherited;
  FData := TObjectList.Create;
end;

destructor TecDataObject.Destroy;
begin
  FData.Free;
  inherited;
end;

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

function TecDataObject.Clone(out Enum: IEnumFormatEtc): HResult;
begin
  Result := S_FALSE;
end;

function TecDataObject.Skip(celt: Integer): HResult;
begin
  FIndex := FIndex + celt;
  if FIndex >= FData.Count then
  begin
    FIndex := FData.Count - 1;
    Result := S_FALSE;
  end else
  if FIndex < 0 then
  begin
    FIndex := 0;
    Result := S_FALSE;
  end
  else Result := S_OK;
end;

{$IFDEF EC_DOTNET}
function TecDataObject.Next(celt: ULONG; rgelt: array of TFormatEtc; out pceltFetched: ULONG): HResult;
begin
  Result := S_FALSE;
  PceltFetched := 0;
  while (PceltFetched < celt) and (FIndex < FData.Count) do
  begin
    with rgelt[PceltFetched] do
     begin
       cfFormat := TDataHolder(FData[FIndex]).Format;
       ptd      := nil;
       dwAspect := DVASPECT_CONTENT;
       lindex   := -1;
       tymed    := TYMED_HGLOBAL;
     end;
    Inc(FIndex);
    Inc(PceltFetched);
  end;
  if PceltFetched = celt then Result := S_OK;
end;
{$ELSE}
function TecDataObject.Next(celt: Integer; out elt; pceltFetched: PLongint): HResult;
var N: integer;
    p: PFormatEtc;
begin
  Result := S_FALSE;
  p := Addr(elt);
  N := 0;
  while (N < celt) and (FIndex < FData.Count) do
  begin
    with p^ do
     begin
       cfFormat := TDataHolder(FData[FIndex]).Format;
       ptd      := nil;
       dwAspect := DVASPECT_CONTENT;
       lindex   := -1;
       tymed    := TYMED_HGLOBAL;
     end;
    Inc(FIndex);
    Inc(N);
    Inc(p);
  end;
  If PceltFetched <> nil then PceltFetched^ := N;
  if N = celt then Result := S_OK;
end;
{$ENDIF}

procedure TecDataObject.SetFormatData(Format: Word;
  {$IFDEF EC_DOTNET}Buffer: TBytes; {$ELSE}var Buffer; {$ENDIF}Count: integer);
var dh: TDataHolder;
begin
  dh := TDataHolder.Create;
  dh.Format := Format;
  SetLength(dh.Data, Count);
  if Count > 0 then
    {$IFDEF EC_DOTNET}
    dh.Data := Buffer;
    {$ELSE}
    Move(Buffer, dh.Data[0], Count);
    {$ENDIF}
  FData.Add(dh);
end;

{$IFDEF EC_DOTNET}
function TecDataObject.DAdvise(var formatetc: TFormatEtc; advf: Longint;
        var advSink: IAdviseSink; out dwConnection: Longint): HResult;
{$ELSE}
function TecDataObject.DAdvise(const formatetc: TFormatEtc; advf: Integer;
  const advSink: IAdviseSink; out dwConnection: Integer): HResult;
{$ENDIF}
begin
  Result := OLE_E_ADVISENOTSUPPORTED;
end;

function TecDataObject.DUnadvise(dwConnection: Integer): HResult;
begin
  Result := OLE_E_ADVISENOTSUPPORTED;
end;

function TecDataObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult;
begin
  Result := OLE_E_ADVISENOTSUPPORTED;
end;

function TecDataObject.EnumFormatEtc(dwDirection: {$IFDEF EC_DOTNET}LongInt{$ELSE}Integer{$ENDIF};
  out enumFormatEtc: IEnumFormatEtc): HResult;
begin
  enumFormatEtc := nil;
  if dwDirection <> DATADIR_GET then
    Result := E_NOTIMPL
  else
    {$IFDEF EC_DOTNET}
    begin
      Result := S_OK;
      enumFormatEtc := Self as IEnumFormatEtc;
    end;
    {$ELSE}
    Result := QueryInterface(IEnumFormatEtc, enumFormatEtc);
    {$ENDIF}
end;

function TecDataObject.GetCanonicalFormatEtc({$IFDEF EC_DOTNET}var{$ELSE}const{$ENDIF} formatetc: TFormatEtc;
  out formatetcOut: TFormatEtc): HResult;
begin
  formatetcOut.ptd := nil;
  Result := E_NOTIMPL;
end;

function TecDataObject.GetData({$IFDEF EC_DOTNET}var{$ELSE}const{$ENDIF} formatetcIn: TFormatEtc;
  out medium: TStgMedium): HResult;
var HGlobalData: HGlobal;
    PGlobalData: {$IFDEF EC_DOTNET}IntPtr{$ELSE}Pointer{$ENDIF};
    i: integer;
begin
  Result := DV_E_FORMATETC;
  {$IFNDEF EC_DOTNET}
  FillChar(medium, sizeof(medium), 0);
  {$ENDIF}
  if QueryGetData(formatetcIn) <> S_OK then exit;
  medium.tymed := TYMED_HGLOBAL;

  for i := 0 to FData.Count - 1 do
   with TDataHolder(FData[i]) do
    if (Format = formatetcIn.cfFormat) and (Length(Data) > 0) then
      begin
        HGlobalData := GlobalAlloc((GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT), Length(Data));
        if HGlobalData <> 0 then
          begin
            PGlobalData := GlobalLock(HGlobalData);
            try
              if PGlobalData <> nil then
                begin
                  {$IFDEF EC_DOTNET}
                  Marshal.Copy(Data, 0, PGlobalData, Length(Data));
                  {$ELSE}
                  Move(Data[0], PGlobalData^, Length(Data));
                  {$ENDIF}
                  medium.hGlobal := HGlobalData;
                  Result := S_OK;
                end;
            finally
              GlobalUnlock(HGlobalData);
            end;
          end;
        Exit;
      end;
end;

function TecDataObject.GetDataHere({$IFDEF EC_DOTNET}var{$ELSE}const{$ENDIF} formatetc: TFormatEtc;
  out medium: TStgMedium): HResult;
begin
  Result := DV_E_FORMATETC;
end;

function TecDataObject.QueryGetData({$IFDEF EC_DOTNET}var{$ELSE}const{$ENDIF} formatetc: TFormatEtc): HResult;
var i: integer;
begin
  Result := DV_E_FORMATETC;
  with formatetc do
   if (dwAspect = DVASPECT_CONTENT) and (tymed = TYMED_HGLOBAL) and (FData.Count > 0) then
    for i := 0 to FData.Count - 1 do
     if cfFormat = TDataHolder(FData[i]).Format then
     begin
       Result := S_OK;
       Exit;
     end;
end;

function TecDataObject.SetData({$IFDEF EC_DOTNET}var{$ELSE}const{$ENDIF} formatetc: TFormatEtc;
  var medium: TStgMedium; fRelease: BOOL): HResult;
begin
  Result := E_NOTIMPL;
end;

{ TDragDrop }

constructor TecDragDrop.Create(AOwner: TComponent);
begin
  inherited;

end;

destructor TecDragDrop.Destroy;
begin
  Active := False;
  inherited;
end;

procedure TecDragDrop.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited;
  if (AComponent = FControl) and (Operation = opRemove) then
    begin
      FControl := nil;
      FWndHandle := 0;
    end;
end;

function TecDragDrop.GetActive: Boolean;
begin
  if (csLoading in ComponentState) or (csDesigning in ComponentState) then
    Result := FActive
  else
    Result := FWndHandle <> 0;
end;

procedure TecDragDrop.Loaded;
begin
  inherited;
  if FActive then
    Active := FActive;
end;

procedure TecDragDrop.SetActive(const Value: Boolean);
begin
  if (csLoading in ComponentState) or (csDesigning in ComponentState) then
    FActive := Value
  else
    begin
      if (FWndHandle <> 0) = Value then Exit;
      if Value then
       begin
         if (FControl <> nil) and FControl.HandleAllocated then
          begin
           FWndHandle := FControl.Handle;
           if RegisterDragDrop(FWndHandle, Self) <> S_OK then
             FWndHandle := 0;
          end;
       end else
       begin
         RevokeDragDrop(FWndHandle);
         FWndHandle := 0;
       end;
    end;
end;

procedure TecDragDrop.SetControl(const Value: TWinControl);
var act: Boolean;
begin
  if FControl = Value then Exit;
  act := Active;
  Active := False;
  FControl := Value;
  if FControl <> nil then
    FControl.FreeNotification(Self);
  Active := act;
end;

function TecDragDrop.InternalHandled(const DataObject: IDataObject): Boolean;
begin
  if GetFormatInfo(DataObject, CF_TEXT) or GetFormatInfo(DataObject, CF_UNICODETEXT) then
    Result := Assigned(FOnSetUnicodeText) or Assigned(FOnSetAnsiText)
  else
    Result := False;
end;

function TecDragDrop.DragEnter({$IFNDEF EC_DOTNET}const{$ENDIF} DataObject: IDataObject;
  KeyState: Longint; Pt: TPoint; var Effect: Longint): HResult;
var Handled: Boolean;
begin
  Result := S_OK;
  FDataObj := DataObject;
  if Assigned(FOnOleDragEnter) then
    begin
      Handled := False;
      FOnOleDragEnter(Self, DataObject, KeyState, pt, Effect, Handled);
      if Handled then
        Exit;
    end;

  if not InternalHandled(DataObject) then
   begin
    Effect := DROPEFFECT_NONE;
    Result := E_INVALIDARG; // All next processing will be aborted
   end;
end;

function TecDragDrop.DragLeave: HResult;
begin
  Result := S_OK;
  FDataObj := nil;
end;

function TecDragDrop.DragOver(KeyState: Integer; Pt: TPoint; var Effect: Longint): HResult;
var Handled: Boolean;
begin
  Result := S_OK;
  Effect := DROPEFFECT_NONE;
  if Assigned(FOnOleDragOver) then
    begin
      Handled := False;
      FOnOleDragOver(Self, FDataObj, KeyState, pt, Effect, Handled);
      if Handled then
        Exit;
    end;

  if InternalHandled(FDataObj) then
    Effect := DROPEFFECT_COPY;
end;

function TecDragDrop.Drop({$IFNDEF EC_DOTNET}const{$ENDIF} DataObject: IDataObject; KeyState: LongInt;
  Pt: TPoint; var Effect: LongInt): HResult;
var Handled: Boolean;
    FFormat: TFormatEtc;
    {$IFDEF EC_DOTNET}
    P: IntPtr;
    S: string;
    {$ELSE}
    P: Pointer;
    {$ENDIF}
    Medium : TStgMedium;
begin
  Result := S_OK;
  FDataObj := nil;

  if Assigned(FOnOleDrop) then
    begin
      Handled := False;
      FOnOleDrop(Self, DataObject, KeyState, pt, Effect, Handled);
      if Handled then
        Exit;
    end;

  if Assigned(FOnSetAnsiText) and
      (GetFormatInfo(DataObject, CF_TEXT, FFormat) or
       GetFormatInfo(DataObject, CF_UNICODETEXT, FFormat)) or
     Assigned(FOnSetUnicodeText)  and
      (GetFormatInfo(DataObject, CF_UNICODETEXT, FFormat) or
       GetFormatInfo(DataObject, CF_TEXT, FFormat)) then
    if Succeeded(DataObject.GetData(FFormat, Medium)) and
       (Medium.hGlobal <> 0) then
      try
        P := GlobalLock(Medium.hGlobal);
        if P <> nil then
          try
            {$IFDEF EC_DOTNET}
            case FFormat.cfFormat of
              CF_TEXT:        S := Marshal.PtrToStringAnsi(P);
              CF_UNICODETEXT: S := Marshal.PtrToStringUni(P);
            end;
            if Assigned(FOnSetAnsiText) then FOnSetAnsiText(Self, Pt, S) else
              if Assigned(FOnSetUnicodeText) then FOnSetUnicodeText(Self, Pt, S);
            {$ELSE}
            if Assigned(FOnSetAnsiText) then
              case FFormat.cfFormat of
                CF_TEXT:        FOnSetAnsiText(Self, Pt, PChar(P));
                CF_UNICODETEXT: FOnSetAnsiText(Self, Pt, PWideChar(P));
              end;
            if Assigned(FOnSetUnicodeText) then
              case FFormat.cfFormat of
                CF_TEXT:        FOnSetUnicodeText(Self, Pt, PChar(P));
                CF_UNICODETEXT: FOnSetUnicodeText(Self, Pt, PWideChar(P));
              end;
            {$ENDIF}
          finally
            GlobalUnlock(Medium.hGlobal);
          end;
      finally
        ReleaseStgMedium(Medium);
      end;
end;

end.
