GDI: A near complete Windows OLE Drag-n-Drop implementation

1 files changed, 922 insertions, 0 deletions

diff --git a/src/corelib/gdi/fpg_oledragdrop.pas b/src/corelib/gdi/fpg_oledragdrop.pas
new file mode 100644
index 00000000..29ebe7c3
--- /dev/null
+++ b/src/corelib/gdi/fpg_oledragdrop.pas
@@ -0,0 +1,922 @@
+{

+    fpGUI  -  Free Pascal GUI Toolkit

+

+    Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this

+    distribution, for details of the copyright.

+

+    See the file COPYING.modifiedLGPL, included in this distribution,

+    for details about redistributing fpGUI.

+

+    This program is distributed in the hope that it will be useful,

+    but WITHOUT ANY WARRANTY; without even the implied warranty of

+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

+

+    Description:

+      This unit implements the OLE Drag-n-Drop functionality of Windows.

+}

+unit fpg_OLEDragDrop;

+

+{$mode delphi}{$H+}

+

+interface

+

+uses

+  Windows, Classes, ActiveX, ShellAPI, fpg_base;

+

+const

+  CFSTR_FILENAMEMAPA          = 'FileNameMap';            { CF_FILENAMEMAPA }

+  CFSTR_FILENAMEMAP           = CFSTR_FILENAMEMAPA;

+  CFSTR_FILEDESCRIPTORA       = 'FileGroupDescriptor';    { CF_FILEGROUPDESCRIPTORA }

+  CFSTR_FILEDESCRIPTOR        = CFSTR_FILEDESCRIPTORA;

+  CFSTR_FILECONTENTS          = 'FileContents';           { CF_FILECONTENTS }

+

+type

+  TfpgOLEFormatEtcList = class(TList)

+  private

+    function    GetFormatEtc(Index: Integer): PFormatEtc;

+  protected

+    procedure   Notify(Ptr: Pointer; Action: TListNotification); override;

+  public

+    constructor CreateCopy(AFormatEtcList: TfpgOLEFormatEtcList);

+    property    FormatEtc[Index: Integer]: PFormatEtc read GetFormatEtc; default;

+  end;

+

+

+  TfpgOLEStgMediumList = class(TList)

+  private

+    function    GetStgMedium(Index: Integer): PStgMedium;

+  protected

+    procedure   Notify(Ptr: Pointer; Action: TListNotification); override;

+  public

+    property    StgMedium[Index: Integer]: PStgMedium read GetStgMedium; default;

+  end;

+

+

+  TfpgOLEDropSource = class(TInterfacedObject, IDropSource)

+  private

+    { IDropSource }

+    function    QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; stdcall;

+    function    GiveFeedback(dwEffect: Longint): HResult; stdcall;

+  end;

+

+

+  TfpgOLEDragDropEffect = (deNone, deCopy, deMove, deLink);

+  TfpgOLEDragEnterEvent = procedure(Sender: TObject; DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect) of object;

+  TfpgOLEDragOverEvent = procedure(Sender: TObject; KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect) of object;

+  TfpgOLEDragDropEvent = procedure(Sender: TObject; DataObj: IDataObject; KeyState: Longint; PT: TPoint; Effect: TfpgOLEDragDropEffect) of object;

+

+

+  TfpgOLEDropTarget = class(TObject, IInterface, IDropTarget)

+  private

+    FDropTarget: TfpgWindowBase;

+    FRegistered: Boolean;

+    FOnDragEnter: TfpgOLEDragEnterEvent;

+    FOnDragOver: TfpgOLEDragOverEvent;

+    FOnDragLeave: TNotifyEvent;

+    FOnDragDrop: TfpgOLEDragDropEvent;

+  protected

+    procedure   DoDragEnter(DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); virtual;

+    procedure   DoDragOver(KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); virtual;

+    procedure   DoDragDrop(DataObj: IDataObject; KeyState: Longint; PT: TPoint; Effect: TfpgOLEDragDropEffect); virtual;

+    { IInterface }

+    function    QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;

+    function    _AddRef: Integer; stdcall;

+    function    _Release: Integer; stdcall;

+    { IDropTarget }

+    function    DragEnter(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;StdCall;

+    function    DragOver(grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult; stdcall;

+    function    DragLeave: HResult; stdcall;

+    function    Drop(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult; stdcall;

+

+    property    OnDragEnter: TfpgOLEDragEnterEvent read FOnDragEnter write FOnDragEnter;

+    property    OnDragOver: TfpgOLEDragOverEvent read FOnDragOver write FOnDragOver;

+    property    OnDragLeave: TNotifyEvent read FOnDragLeave write FOnDragLeave;

+    property    OnDragDrop: TfpgOLEDragDropEvent read FOnDragDrop write FOnDragDrop;

+  public

+    constructor Create(ADropTargetWidget: TfpgWindowBase); reintroduce; { Actually a TfpgWidget }

+    destructor  Destroy; override;

+    procedure   RegisterDragDrop;

+    procedure   RevokeDragDrop;

+    property    DropTarget: TfpgWindowBase read FDropTarget;

+  end;

+

+

+  TfpgOLEDataObject = class(TInterfacedObject, IDataObject)

+  private

+    FFormatEtcList: TfpgOLEFormatEtcList;

+    FStgMediumList: TfpgOLEStgMediumList;

+    function    LookupFormatEtc(AFormat: TFormatEtc): Integer;

+  protected

+    { IDataObject }

+    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; const medium: TStgMedium; fRelease: BOOL): HResult; stdcall;

+    function    EnumFormatEtc(dwDirection: DWORD; out enumFormatEtc: IEnumFormatEtc): HResult; stdcall;

+    function    DAdvise(const formatetc: TFormatEtc; advf: DWORD; const advSink: IAdviseSink; out dwConnection: DWORD): HResult; stdcall;

+    function    DUnadvise(dwConnection: DWORD): HResult; stdcall;

+    function    EnumDAdvise(out enumAdvise: IEnumStatData): HResult; stdcall;

+  public

+    constructor Create; overload;

+    constructor Create(AFormatEtcList: TfpgOLEFormatEtcList); overload;

+    destructor  Destroy; override;

+    property    FormatEtcList: TfpgOLEFormatEtcList read FFormatEtcList;

+    property    StgMediumList: TfpgOLEStgMediumList read FStgMediumList;

+  end;

+

+

+  TfpgOLEEnumFormatEtc = class(TInterfacedObject, IEnumFORMATETC)

+  private

+    FFormatEtcList: TfpgOLEFormatEtcList;

+    FIndex: Integer;

+  protected

+    { IEnumFORMATETC }

+    function    Next(celt: ULong; out elt:FormatEtc; pceltFetched: pULong=nil): HResult; stdcall;

+    function    Skip(celt: ULong): HResult; stdcall;

+    function    Reset: HResult; stdcall;

+    function    Clone(out Enum: IEnumFormatEtc): HResult; stdcall;

+  public

+    constructor Create(AFormatEtcList: TfpgOLEFormatEtcList);

+    destructor  Destroy; override;

+  end;

+

+

+  TDragFilesSource = class(TObject)

+  private

+    FFileNames: TStrings;

+    FAliasFileNames: TStrings;

+    function    GetAliasFileNames: TStrings;

+    function    GetSourceFileNames: TStrings;

+    procedure   SetAliasFileNames(const Value: TStrings);

+    procedure   SetSourceFileNames(const Value: TStrings);

+  public

+    constructor Create;

+    destructor  Destroy; override;

+    procedure   Execute;

+    property    SourceFileNames: TStrings read GetSourceFileNames write SetSourceFileNames;

+    property    AliasFileNames: TStrings read GetAliasFileNames write SetAliasFileNames;

+  end;

+

+

+  TDragAcceptFilesEvent = function(Sender: TObject; FileNames: TStrings): Boolean of object;

+  TDragAcceptPositionEvent = function(Sender: TObject; PT: TPoint): Boolean of object;

+  TDropFilesEvent = procedure(Sender: TObject; PT: TPoint; FileNames: TStrings) of object;

+

+

+  TDragFilesTarget = class(TfpgOLEDropTarget)

+  private

+    FDragAcceptFiles: Boolean;

+    FOnDragAcceptFiles: TDragAcceptFilesEvent;

+    FOnDragAcceptPosition: TDragAcceptPositionEvent;

+    FOnDropFiles: TDropFilesEvent;

+    procedure   GetFileNamesFromDropHandle(DropHandle: HDROP; SL: TStrings);

+    procedure   StreamToFile(Stream: IStream; const FileName: string);

+  protected

+    function    DoDragAcceptFiles(DataObj: IDataObject): Boolean;

+    function    DoDragAcceptPosition(PT: TPoint): Boolean;

+    procedure   DoDropFiles(DataObj: IDataObject; PT: TPoint);

+    procedure   DoDragEnter(DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); override;

+    procedure   DoDragOver(KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); override;

+    procedure   DoDragDrop(DataObj: IDataObject; KeyState: Longint; PT: TPoint; Effect: TfpgOLEDragDropEffect); override;

+  public

+    property    OnDragAcceptFiles: TDragAcceptFilesEvent read FOnDragAcceptFiles write FOnDragAcceptFiles;

+    property    OnDragAcceptPosition: TDragAcceptPositionEvent read FOnDragAcceptPosition write FOnDragAcceptPosition;

+    property    OnDropFiles: TDropFilesEvent read FOnDropFiles write FOnDropFiles;

+  end;

+

+

+implementation

+

+uses

+  SysUtils, ShlObj, fpg_widget;

+

+var

+  CF_FILENAMEMAP: Cardinal;

+  CF_FILEDESCRIPTOR: Cardinal;

+  CF_FILECONTENTS: Cardinal;

+

+procedure DeepCopyFormatEtc(P1, P2: PFormatEtc);

+begin

+  P2^ := P1^;

+  if P1^.ptd <> nil then begin

+    P2^.ptd := CoTaskMemAlloc(SizeOf(tagDVTARGETDEVICE));

+    P2^.ptd^ := P1^.ptd^;

+  end;

+end;

+

+function DupGlobalMem(hMem: HGLOBAL): HGLOBAL;

+var

+  len: DWORD;

+  Source: Pointer;

+  Dest: HGLOBAL;

+begin

+  len := GlobalSize(hMem);

+  Source := GlobalLock(hMem);

+  Dest := GlobalAlloc(GMEM_FIXED, len);

+  Move(Source^, Pointer(Dest)^, len);

+  GlobalUnlock(hMem);

+  Result := Dest;

+end;

+

+{ TDragFilesSource }

+

+constructor TDragFilesSource.Create;

+begin

+  inherited Create;

+  FFileNames := TStringList.Create;

+  FAliasFileNames := TStringList.Create;

+end;

+

+destructor TDragFilesSource.Destroy;

+begin

+  FreeAndNil(FFileNames);

+  FreeAndNil(FAliasFileNames);

+  inherited Destroy;

+end;

+

+procedure TDragFilesSource.Execute;

+var

+  DataObject: TfpgOLEDataObject;

+  DropSource: TfpgOLEDropSource;

+  dwEffect: DWORD;

+  dwResult: HRESULT;

+  I: Integer;

+  F: PFormatEtc;

+  S: string;

+  M: PStgMedium;

+begin

+  DataObject := TfpgOLEDataObject.Create;

+

+  S := '';

+  for I := 0 to FFileNames.Count - 1 do begin

+    SetLength(S, Length(S)+Length(FFileNames[I])+1);

+    Move(FFileNames[I][1], S[Length(S)-Length(FFileNames[I])], Length(FFileNames[I]));

+    S[Length(S)] := #0;

+  end;

+  SetLength(S, Length(S)+1);

+  S[Length(S)] := #0;

+

+  New(F);

+  F^.cfFormat := CF_HDROP;

+  F^.ptd := nil;

+  F^.dwAspect := DVASPECT_CONTENT;

+  F^.lindex := -1;

+  F^.tymed := TYMED_HGLOBAL;

+  DataObject.FormatEtcList.Add(F);

+

+  New(M);

+  M^.tymed := TYMED_HGLOBAL;

+  M^.hGlobal := Cardinal(GlobalAlloc(GMEM_FIXED, SizeOf(TDropFiles)+Length(S)));

+  PDropFiles(M^.hGlobal)^.pFiles := SizeOf(TDropFiles);

+  PDropFiles(M^.hGlobal)^.pt := Point(0,0);

+  PDropFiles(M^.hGlobal)^.fNC := FALSE;

+  PDropFiles(M^.hGlobal)^.fWide := FALSE;

+  Move(S[1], PChar(M^.hGlobal+SizeOf(TDropFiles))^, Length(S));

+  DataObject.StgMediumList.Add(M);

+

+  if (FAliasFileNames.Count > 0) and (FAliasFileNames.Count = FFileNames.Count) then begin

+    S := '';

+    for I := 0 to FAliasFileNames.Count - 1 do begin

+      SetLength(S, Length(S)+Length(FAliasFileNames[I])+1);

+      Move(FAliasFileNames[I][1], S[Length(S)-Length(FAliasFileNames[I])], Length(FAliasFileNames[I]));

+      S[Length(S)] := #0;

+    end;

+    SetLength(S, Length(S)+1);

+    S[Length(S)] := #0;

+

+    New(F);

+    F^.cfFormat := CF_FILENAMEMAP;

+    F^.ptd := nil;

+    F^.dwAspect := DVASPECT_CONTENT;

+    F^.lindex := -1;

+    F^.tymed := TYMED_HGLOBAL;

+    DataObject.FormatEtcList.Add(F);

+

+    New(M);

+    M^.tymed := TYMED_HGLOBAL;

+    M^.hGlobal := Cardinal(GlobalAlloc(GMEM_FIXED, Length(S)));

+    Move(S[1], PChar(M^.hGlobal)^, Length(S));

+    DataObject.StgMediumList.Add(M);

+  end;

+

+  DropSource := TfpgOLEDropSource.Create;

+  dwResult := ActiveX.DoDragDrop(DataObject as IDataObject, DropSource as IDropSource, DROPEFFECT_COPY, @dwEffect);

+

+  if dwResult = DRAGDROP_S_DROP then begin

+    if dwEffect = DROPEFFECT_COPY then begin

+    end;

+  end;

+end;

+

+function TDragFilesSource.GetAliasFileNames: TStrings;

+begin

+  Result := FAliasFileNames;

+end;

+

+function TDragFilesSource.GetSourceFileNames: TStrings;

+begin

+  Result := FFileNames;

+end;

+

+procedure TDragFilesSource.SetAliasFileNames(const Value: TStrings);

+begin

+  FAliasFileNames.Assign(Value);

+end;

+

+procedure TDragFilesSource.SetSourceFileNames(const Value: TStrings);

+begin

+  FFileNames.Assign(Value);

+end;

+

+{ TfpgOLEDropSource }

+

+function TfpgOLEDropSource.GiveFeedback(dwEffect: Integer): HResult;

+begin

+  Result := DRAGDROP_S_USEDEFAULTCURSORS;

+end;

+

+function TfpgOLEDropSource.QueryContinueDrag(fEscapePressed: BOOL;

+  grfKeyState: Integer): HResult;

+begin

+  if FEscapePressed then

+    Result := DRAGDROP_S_CANCEL

+  else if (grfKeyState and (MK_LBUTTON or MK_RBUTTON) = 0) then

+    Result := DRAGDROP_S_DROP

+  else

+    Result := S_OK;

+end;

+

+{ TfpgOLEDataObject }

+

+constructor TfpgOLEDataObject.Create(AFormatEtcList: TfpgOLEFormatEtcList);

+begin

+  inherited Create;

+  FFormatEtcList := TfpgOLEFormatEtcList.CreateCopy(AFormatEtcList);

+  FStgMediumList := TfpgOLEStgMediumList.Create;

+end;

+

+constructor TfpgOLEDataObject.Create;

+begin

+  inherited Create;

+  FFormatEtcList := TfpgOLEFormatEtcList.Create;

+  FStgMediumList := TfpgOLEStgMediumList.Create;

+end;

+

+function TfpgOLEDataObject.DAdvise(const formatetc: TFormatEtc; advf: DWORD;

+  const advSink: IAdviseSink; out dwConnection: DWORD): HResult;

+begin

+  Result := OLE_E_ADVISENOTSUPPORTED;

+end;

+

+destructor TfpgOLEDataObject.Destroy;

+begin

+  FreeAndNil(FFormatEtcList);

+  FreeAndNil(FStgMediumList);

+  inherited Destroy;

+end;

+

+function TfpgOLEDataObject.DUnadvise(dwConnection: DWORD): HResult;

+begin

+  Result := OLE_E_ADVISENOTSUPPORTED;

+end;

+

+function TfpgOLEDataObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult;

+begin

+  Result := OLE_E_ADVISENOTSUPPORTED;

+end;

+

+function TfpgOLEDataObject.EnumFormatEtc(dwDirection: DWORD;

+  out enumFormatEtc: IEnumFormatEtc): HResult;

+begin

+  if dwDirection = DATADIR_GET then begin

+    enumFormatEtc := TfpgOLEEnumFormatEtc.Create(FFormatEtcList) as IEnumFormatEtc;

+    Result := S_OK;

+  end

+  else begin

+    Result := E_NOTIMPL;

+  end;

+end;

+

+function TfpgOLEDataObject.GetCanonicalFormatEtc(const formatetc: TFormatEtc;

+  out formatetcOut: TFormatEtc): HResult;

+begin

+  // Apparently we have to set this field to NULL even though we don't do anything else

+  formatetcOut.ptd := nil;

+  Result := E_NOTIMPL;

+end;

+

+function TfpgOLEDataObject.GetData(const formatetcIn: TFormatEtc;

+  out medium: TStgMedium): HResult;

+var

+  Idx: Integer;

+begin

+  Idx := LookupFormatEtc(formatetcIn);

+  if Idx = -1 then

+    Result := DV_E_FORMATETC

+  else begin

+    medium.tymed := FFormatEtcList[Idx]^.tymed;

+    medium.PUnkForRelease := nil;

+    if medium.tymed = TYMED_HGLOBAL then begin

+      medium.hGlobal := DupGlobalMem(FStgMediumList[Idx]^.hGlobal);

+      Result := S_OK;

+    end

+    else

+      Result := DV_E_FORMATETC;

+  end;

+end;

+

+function TfpgOLEDataObject.GetDataHere(const formatetc: TFormatEtc;

+  out medium: TStgMedium): HResult;

+begin

+  Result := DV_E_FORMATETC;

+end;

+

+function TfpgOLEDataObject.LookupFormatEtc(AFormat: TFormatEtc): Integer;

+var

+  I: Integer;

+begin

+  Result := -1;

+  for I := 0 to FFormatEtcList.Count - 1 do begin

+    if (FFormatEtcList[I]^.cfFormat = AFormat.cfFormat) and

+       (FFormatEtcList[I]^.dwAspect = AFormat.dwAspect) and

+       (FFormatEtcList[I]^.tymed = AFormat.tymed) then begin

+      Result := I;

+      Break;

+    end;

+  end;

+end;

+

+function TfpgOLEDataObject.QueryGetData(const formatetc: TFormatEtc): HResult;

+begin

+  if LookupFormatEtc(formatetc) >= 0 then begin

+    Result := S_OK;

+  end

+  else begin

+    Result := DV_E_FORMATETC;

+  end;

+end;

+

+function TfpgOLEDataObject.SetData(const formatetc: TFormatEtc;

+  const medium: TStgMedium; fRelease: BOOL): HResult;

+begin

+  Result := E_NOTIMPL;

+end;

+

+{ TfpgOLEEnumFormatEtc }

+

+function TfpgOLEEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult;

+var

+  C: TfpgOLEEnumFormatEtc;

+begin

+  // make a duplicate enumerator

+  C := TfpgOLEEnumFormatEtc.Create(FFormatEtcList);

+  // manually set the index state

+  C.FIndex := FIndex;

+  Enum := C as IEnumFormatEtc;

+  Result := S_OK;

+end;

+

+constructor TfpgOLEEnumFormatEtc.Create(AFormatEtcList: TfpgOLEFormatEtcList);

+begin

+  FFormatEtcList := TfpgOLEFormatEtcList.CreateCopy(AFormatEtcList);

+  FIndex := 0;

+end;

+

+destructor TfpgOLEEnumFormatEtc.Destroy;

+begin

+  FreeAndNil(FFormatEtcList);

+  inherited;

+end;

+

+function TfpgOLEEnumFormatEtc.Next(celt: ULong; out elt:FormatEtc;

+  pceltFetched: pULong): HResult;

+var

+  Copied: Integer;

+  OutBuf: PFormatEtc;

+begin

+  // copy the FORMATETC structures into the caller's buffer

+  OutBuf := PFormatEtc(@elt);

+  Copied := 0;

+  while(FIndex < FFormatEtcList.Count) and (Copied < celt) do begin

+    DeepCopyFormatEtc(FFormatEtcList[FIndex], OutBuf);

+    OutBuf := PFormatEtc(Cardinal(OutBuf) + SizeOf(TFormatEtc));

+    Inc(Copied);

+    FIndex := FIndex + 1;

+  end;

+

+  // store result

+  if (pceltFetched <> nil) then

+    pceltFetched^ := Copied;

+

+  // did we copy all that was requested?

+  if (Copied = celt) then Result := S_OK

+  else Result := S_FALSE;

+end;

+

+function TfpgOLEEnumFormatEtc.Reset: HResult;

+begin

+  FIndex := 0;

+  Result := S_OK;

+end;

+

+function TfpgOLEEnumFormatEtc.Skip(celt: ULong): HResult;

+begin

+  FIndex := FIndex + celt;

+  if FIndex <= FFormatEtcList.Count then Result := S_OK

+  else Result := S_FALSE;

+end;

+

+{ TfpgOLEFormatEtcList }

+

+constructor TfpgOLEFormatEtcList.CreateCopy(AFormatEtcList: TfpgOLEFormatEtcList);

+var

+  I: Integer;

+  P: PFormatEtc;

+begin

+  Create;

+  for I := 0 to AFormatEtcList.Count - 1 do begin

+    New(P);

+    DeepCopyFormatEtc(AFormatEtcList[I], P);

+    Add(P);

+  end;

+end;

+

+function TfpgOLEFormatEtcList.GetFormatEtc(Index: Integer): PFormatEtc;

+begin

+  Result := PFormatEtc(Get(Index));

+end;

+

+procedure TfpgOLEFormatEtcList.Notify(Ptr: Pointer; Action: TListNotification);

+begin

+  if Action = lnDeleted then begin

+    if PFormatEtc(Ptr)^.ptd <> nil then begin

+      CoTaskMemFree(PFormatEtc(Ptr)^.ptd);

+    end;

+    Dispose(PFormatEtc(Ptr));

+  end;

+  inherited;

+end;

+

+{ TfpgOLEStgMediumList }

+

+function TfpgOLEStgMediumList.GetStgMedium(Index: Integer): PStgMedium;

+begin

+  Result := PStgMedium(Get(Index));

+end;

+

+procedure TfpgOLEStgMediumList.Notify(Ptr: Pointer; Action: TListNotification);

+begin

+  if Action = lnDeleted then begin

+    if PStgMedium(Ptr)^.hGlobal <> 0 then begin

+      GlobalFree(PStgMedium(Ptr)^.hGlobal);

+    end;

+    Dispose(Ptr);

+  end;

+  inherited;

+end;

+

+{ TfpgOLEDropTarget }

+

+function TfpgOLEDropTarget.DragEnter(const dataObj: IDataObject;

+  grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;

+var

+  Effect: TfpgOLEDragDropEffect;

+begin

+  dwEffect := DROPEFFECT_NONE;

+  Effect := deNone;

+  DoDragEnter(dataObj, grfKeyState, pt, Effect);

+  case Effect of

+    deNone: dwEffect := DROPEFFECT_NONE;

+    deCopy: dwEffect := DROPEFFECT_COPY;

+    deMove: dwEffect := DROPEFFECT_MOVE;

+    deLink: dwEffect := DROPEFFECT_LINK;

+  end;

+  Result := S_OK;

+end;

+

+function TfpgOLEDropTarget.DragLeave: HResult;

+begin

+  Result := S_OK;

+end;

+

+function TfpgOLEDropTarget.DragOver(grfKeyState: DWORD; pt: TPoint;

+  var dwEffect: DWORD): HResult;

+var

+  Effect: TfpgOLEDragDropEffect;

+begin

+  if ((MK_SHIFT and grfKeyState) = MK_SHIFT) and

+     ((dwEffect and DROPEFFECT_MOVE) = DROPEFFECT_MOVE) then begin

+    Effect := deMove;

+  end;

+  if ((MK_CONTROL and grfKeyState) = MK_CONTROL) and

+     ((dwEffect and DROPEFFECT_COPY) = DROPEFFECT_COPY) then begin

+    Effect := deCopy;

+  end;

+  if dwEffect and DROPEFFECT_COPY > 0 then Effect := deCopy

+  else if dwEffect and DROPEFFECT_MOVE  > 0 then Effect := deMove

+  else if dwEffect and DROPEFFECT_LINK > 0 then Effect := deLink

+  else Effect := deNone;

+  DoDragOver(grfKeyState, pt, Effect);

+  case Effect of

+    deNone: dwEffect := DROPEFFECT_NONE;

+    deCopy: dwEffect := DROPEFFECT_COPY;

+    deMove: dwEffect := DROPEFFECT_MOVE;

+    deLink: dwEffect := DROPEFFECT_LINK;

+  end;

+  Result := S_OK;

+end;

+

+function TfpgOLEDropTarget.Drop(const dataObj: IDataObject;

+  grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;

+var

+  Effect: TfpgOLEDragDropEffect;

+begin

+  if dwEffect and DROPEFFECT_COPY > 0 then Effect := deCopy

+  else if dwEffect and DROPEFFECT_MOVE  > 0 then Effect := deMove

+  else if dwEffect and DROPEFFECT_LINK > 0 then Effect := deLink

+  else Effect := deNone;

+  DoDragDrop(dataObj, grfKeyState, pt, Effect);

+  Result := S_OK;

+end;

+

+function TfpgOLEDropTarget._AddRef: Integer;

+begin

+  Result := 1;

+end;

+

+function TfpgOLEDropTarget._Release: Integer;

+begin

+  Result := 1;

+end;

+

+function TfpgOLEDropTarget.QueryInterface(const IID: TGUID; out Obj): HResult;

+begin

+  if GetInterface(IID, Obj) then

+    Result := 0

+  else

+    Result := E_NOINTERFACE;

+end;

+

+constructor TfpgOLEDropTarget.Create(ADropTargetWidget: TfpgWindowBase);

+begin

+  inherited Create;

+  FDropTarget := ADropTargetWidget;

+  FRegistered := False;

+end;

+

+procedure TfpgOLEDropTarget.RegisterDragDrop;

+begin

+  ActiveX.RegisterDragDrop(TfpgWidget(FDropTarget).WinHandle, Self as IDropTarget);

+  FRegistered := True;

+end;

+

+procedure TfpgOLEDropTarget.RevokeDragDrop;

+begin

+  FRegistered := False;

+  ActiveX.RevokeDragDrop(TfpgWidget(FDropTarget).WinHandle);

+end;

+

+destructor TfpgOLEDropTarget.Destroy;

+begin

+  if FRegistered then RevokeDragDrop;

+  inherited;

+end;

+

+procedure TfpgOLEDropTarget.DoDragEnter(DataObj: IDataObject;

+  KeyState: Integer; PT: TPoint; var Effect: TfpgOLEDragDropEffect);

+begin

+  if Assigned(FOnDragEnter) then begin

+    FOnDragEnter(Self, DataObj, KeyState, PT, Effect);

+  end;

+end;

+

+procedure TfpgOLEDropTarget.DoDragOver(KeyState: Integer; PT: TPoint;

+  var Effect: TfpgOLEDragDropEffect);

+begin

+  if Assigned(FOnDragOver) then begin

+    FOnDragOver(Self, KeyState, PT, Effect);

+  end;

+end;

+

+procedure TfpgOLEDropTarget.DoDragDrop(DataObj: IDataObject; KeyState: Integer;

+  PT: TPoint; Effect: TfpgOLEDragDropEffect);

+begin

+  if Assigned(FOnDragDrop) then begin

+    FOnDragDrop(Self, DataObj, KeyState, PT, Effect);

+  end;

+end;

+

+{ TDragFilesTarget }

+

+function TDragFilesTarget.DoDragAcceptFiles(DataObj: IDataObject): Boolean;

+const

+  FormatEtcHDrop:           TFormatEtc = (cfFormat:CF_HDROP;ptd:nil;dwAspect:DVASPECT_CONTENT;lindex:-1;tymed:TYMED_HGLOBAL);

+  FormatEtcFileDescriptor:  TFormatEtc = (cfFormat:0;ptd:nil;dwAspect:DVASPECT_CONTENT;lindex:-1;tymed:TYMED_HGLOBAL);

+  FormatEtcFileContents:    TFormatEtc = (cfFormat:0;ptd:nil;dwAspect:DVASPECT_CONTENT;lindex:-1;tymed:TYMED_ISTREAM);

+var

+  StgMedium: TStgMedium;

+  DropHandle: HDROP;

+  EnumFormatEtc: IEnumFORMATETC;

+  FE: TFormatEtc;

+  FetchedCount: Longint;

+  FormatName: array[0..MAX_PATH] of Char;

+  FileGroupDescriptor: PFileGroupDescriptorA;

+  I, Count: Integer;

+  FileDescriptor: TFileDescriptorA;

+  FileNames: TStringList;

+begin

+  FileNames := TStringList.Create;

+  try

+    if Assigned(FOnDragAcceptFiles) then

+    begin

+      Result := False;

+      FormatEtcFileDescriptor.cfFormat := CF_FILEDESCRIPTOR;

+      FormatEtcFileContents.cfFormat := CF_FILECONTENTS;

+

+      if (DataObj.QueryGetData(FormatEtcHDrop) = S_OK) and

+         (DataObj.GetData(FormatEtcHDrop,StgMedium) = S_OK) then

+      begin

+        DropHandle := StgMedium.hGlobal;

+        GetFileNamesFromDropHandle(DropHandle, FileNames);

+        Result := FOnDragAcceptFiles(Self, FileNames);

+        ReleaseStgMedium(StgMedium);

+      end

+      else

+      if (DataObj.QueryGetData(FormatEtcFileDescriptor) = S_OK) and

+         (DataObj.QueryGetData(FormatEtcFileContents) = S_OK) and

+         (DataObj.GetData(FormatEtcFileDescriptor,StgMedium) = S_OK) then

+      begin

+        FileGroupDescriptor := GlobalLock(StgMedium.hGlobal);

+        if FileGroupDescriptor <> nil then

+        begin

+          Count := FileGroupDescriptor^.cItems;

+          I := 0;

+          while I < Count do

+          begin

+            FileDescriptor := FileGroupDescriptor^.fgd[I];

+            FileNames.Add(FileDescriptor.cFileName);

+            Inc(I);

+          end;

+          GlobalUnlock(StgMedium.hGlobal);

+        end;

+        Result := FOnDragAcceptFiles(Self, FileNames);

+        ReleaseStgMedium(StgMedium);

+      end

+      else

+      begin

+//        DataObj.EnumFormatEtc(DATADIR_GET, EnumFormatEtc);

+//        EnumFormatEtc.Reset;

+//        while EnumFormatEtc.Next(1, FE, @FetchedCount) = S_OK do begin

+//          GetClipboardFormatName(FE.cfFormat,FormatName,MAX_PATH);

+//          ShowMessage(FormatName);

+//        end;

+      end;

+    end

+    else

+    begin

+      Result := True;

+    end;

+  finally

+    FileNames.Free;

+  end;

+end;

+

+procedure TDragFilesTarget.DoDragEnter(DataObj: IDataObject;

+  KeyState: Integer; PT: TPoint; var Effect: TfpgOLEDragDropEffect);

+begin

+  FDragAcceptFiles := DoDragAcceptFiles(DataObj);

+  if FDragAcceptFiles and DoDragAcceptPosition(PT) then begin

+    inherited;

+  end else begin

+    Effect := deNone;

+  end;

+end;

+

+procedure TDragFilesTarget.DoDragOver(KeyState: Integer; PT: TPoint;

+  var Effect: TfpgOLEDragDropEffect);

+begin

+  if FDragAcceptFiles and DoDragAcceptPosition(PT) then begin

+    inherited;

+  end else begin

+    Effect := deNone;

+  end;

+end;

+

+procedure TDragFilesTarget.DoDragDrop(DataObj: IDataObject;

+  KeyState: Integer; PT: TPoint; Effect: TfpgOLEDragDropEffect);

+begin

+  DoDropFiles(DataObj, PT);

+  inherited;

+end;

+

+function TDragFilesTarget.DoDragAcceptPosition(PT: TPoint): Boolean;

+begin

+  if Assigned(FOnDragAcceptPosition) then begin

+    Result := FOnDragAcceptPosition(Self, PT);

+  end else begin

+    Result := True;

+  end;

+end;

+

+procedure TDragFilesTarget.DoDropFiles(DataObj: IDataObject; PT: TPoint);

+const

+  FormatEtcHDrop: TFormatEtc = (cfFormat:CF_HDROP;ptd:nil;dwAspect:DVASPECT_CONTENT;lindex:-1;tymed:TYMED_HGLOBAL);

+  FormatEtcFileDescriptor: TFormatEtc =

+    (cfFormat:0;ptd:nil;dwAspect:DVASPECT_CONTENT;lindex:-1;tymed:TYMED_HGLOBAL);

+  FormatEtcFileContents: TFormatEtc =

+    (cfFormat:0;ptd:nil;dwAspect:DVASPECT_CONTENT;lindex:-1;tymed:TYMED_ISTREAM);

+var

+  StgMedium, StgMediumContents: TStgMedium;

+  DropHandle: HDROP;

+  FileNames: TStringList;

+  FileGroupDescriptor: PFileGroupDescriptorA;

+  I, Count: Integer;

+  FileDescriptor: TFileDescriptorA;

+  Path: array[0..MAX_PATH] of Char;

+  TempFileName: string;

+begin

+  if not Assigned(FOnDropFiles) then Exit;

+  FileNames := TStringList.Create;

+  try

+    FormatEtcFileDescriptor.cfFormat := CF_FILEDESCRIPTOR;

+    FormatEtcFileContents.cfFormat := CF_FILECONTENTS;

+    if (DataObj.QueryGetData(FormatEtcHDrop) = S_OK) and

+       (DataObj.GetData(FormatEtcHDrop,StgMedium) = S_OK) then begin

+      DropHandle := StgMedium.hGlobal;

+      GetFileNamesFromDropHandle(DropHandle, FileNames);

+      FOnDropFiles(Self, PT, FileNames);

+      ReleaseStgMedium(StgMedium);

+    end else

+    if (DataObj.QueryGetData(FormatEtcFileDescriptor) = S_OK) and

+       (DataObj.QueryGetData(FormatEtcFileContents) = S_OK) and

+       (DataObj.GetData(FormatEtcFileDescriptor,StgMedium) = S_OK) then begin

+      GetTempPath(MAX_PATH, Path);

+      GetTempFileName(Path, 'PXM', 0, Path);

+      FileGroupDescriptor := GlobalLock(StgMedium.hGlobal);

+      if FileGroupDescriptor <> nil then begin

+        Count := FileGroupDescriptor^.cItems;

+        I := 0;

+        while I < Count do begin

+          FileDescriptor := FileGroupDescriptor^.fgd[I];

+          TempFileName := ChangeFileExt(Path, ExtractFileExt(FileDescriptor.cFileName));

+          FormatEtcFileContents.lindex := I;

+          if (DataObj.GetData(FormatEtcFileContents,StgMediumContents) = S_OK) then begin

+            StreamToFile(IStream(StgMediumContents.pstm), TempFileName);

+            FileNames.Clear;

+            FileNames.Add(TempFileName);

+            FOnDropFiles(Self, PT, FileNames);

+            ReleaseStgMedium(StgMediumContents);

+          end;

+          Inc(I);

+        end;

+        GlobalUnlock(StgMedium.hGlobal);

+      end;

+      FOnDropFiles(Self, PT, FileNames);

+      ReleaseStgMedium(StgMedium);

+      ReleaseStgMedium(StgMediumContents);

+    end;

+  finally

+    FileNames.Free;

+  end;

+end;

+

+procedure TDragFilesTarget.GetFileNamesFromDropHandle(DropHandle: HDROP; SL: TStrings);

+var

+  I: Integer;

+  Path: array[0..MAX_PATH] of Char;

+begin

+  for I := 0 to DragQueryFile(DropHandle, $FFFFFFFF, nil, 0) do begin

+    DragQueryFile(DropHandle, I, Path, MAX_PATH);

+    SL.Add(Path);

+  end;

+  DragFinish(DropHandle);

+end;

+

+procedure TDragFilesTarget.StreamToFile(Stream: IStream; const FileName: string);

+const

+  BLOCK_SIZE = 4096;

+var

+  BytesRead: Longint;

+  FileStream: TFileStream;

+  Buffer: array[0..BLOCK_SIZE] of Byte;

+begin

+  FileStream := TFileStream.Create(FileName, fmCreate);

+  try

+    while (Stream.Read(@Buffer[0], BLOCK_SIZE, @BytesRead) = S_OK) and (BytesRead > 0) do begin

+      FileStream.Write(Buffer, BytesRead);

+    end;

+  finally

+    FileStream.Free;

+  end;

+end;

+

+initialization

+  CF_FILENAMEMAP := RegisterClipboardFormat(CFSTR_FILENAMEMAP);

+  CF_FILEDESCRIPTOR := RegisterClipboardFormat(CFSTR_FILEDESCRIPTOR);

+  CF_FILECONTENTS := RegisterClipboardFormat(CFSTR_FILECONTENTS);

+

+finalization

+

+end.

+