[Lazarus] GTK2: Drag files to other applications (to the file manager, Thunar, Nautilus, etc)

[Bernd]

Intermediate result of first experiments on windows. May the next
person who googles for this rare problem (everybody knows how to
receive files but only few people have ever implemented an IDataObject
 themselves and then posted the results) find this post in which it is
all condensed into only 200 lines of a readable programming language:

unit win32dragdrop;

{$mode objfpc}{$H+}

interface

procedure DoVeryComplicatedStuffThatIsNotWellDocumented;


implementation
uses
  Classes, Windows, ActiveX, shlobj;

const
  MyFileDragFormat: FORMATETC = (
    CfFormat : CF_HDROP;
    Ptd      : nil;
    dwAspect : DVASPECT_CONTENT;
    lindex   : -1;
    tymed    : TYMED_HGLOBAL;
  );

type

  { TDropSource }

  TDropSource = class(TInterfacedObject, IDropSource)
    function QueryContinueDrag(fEscapePressed: BOOL; grfKeyState:
DWORD): HResult; StdCall;
    function GiveFeedback(dwEffect: DWORD): HResult; StdCall;
  end;

  { TDataObject }

  TDataObject = class(TInterfacedObject, IDataObject)
    function GetData(const formatetcIn: FORMATETC; out medium:
STGMEDIUM): HRESULT; STDCALL;
    function GetDataHere(const pformatetc: FormatETC; out medium:
STGMEDIUM): HRESULT; STDCALL;
    function QueryGetData(const pformatetc: FORMATETC): HRESULT; STDCALL;
    function GetCanonicalFormatEtc(const pformatetcIn: FORMATETC; out
pformatetcOut: FORMATETC): HResult; STDCALl;
    function SetData(const pformatetc: FORMATETC; const medium:
STGMEDIUM; FRelease: BOOL): HRESULT; StdCall;
    function EnumFormatEtc(dwDirection: DWord; out enumformatetcpara:
IENUMFORMATETC): HRESULT; StdCall;
    function DAdvise(const formatetc: FORMATETC; advf: DWORD; const
AdvSink: IAdviseSink; out dwConnection: DWORD): HRESULT; StdCall;
    function DUnadvise(dwconnection: DWord): HRESULT; StdCall;
    function EnumDAdvise(out enumAdvise: IEnumStatData): HResult; StdCall;
  private
    function HaveThisFormat(const f: TFORMATETC): Boolean;
  end;

{$note SHCreateStdEnumFmtEtc() definition in shlobj is wrong, report this bug}
function SHCreateStdEnumFmtEtc(cfmt:UINT; afmt: PFORMATETC; var
ppenumFormatEtc:IEnumFORMATETC):HRESULT;StdCall;external 'shell32'
name 'SHCreateStdEnumFmtEtc';

procedure DoVeryComplicatedStuffThatIsNotWellDocumented;
var
  DataObject: IDataObject;
  DropSource: IDropSource;
  DWEffect: DWord;
begin
  DataObject := TDataObject.Create;
  DropSource := TDropSource.Create;
  DoDragDrop(DataObject, DropSource, DROPEFFECT_COPY, @DWEffect);
  WriteLn(DWEffect);
end;

{ TDataObject }


function TDataObject.GetData(const formatetcIn: FORMATETC; out medium:
STGMEDIUM): HRESULT; STDCALL;
var
  FileList: TStringList;
  FileName: String;
  sFileList: WideString;
  BufLen: PtrInt;
  hgDropFiles: THANDLE;
  pgDropFiles: PDROPFILES;

begin
  // This method may be called multiple times amd also even when no
  // drop happens at all because I am using CF_HDROP which means: files
  // exist in the file system and so windows thinks it is ok to access
  // the dragged data immediately after dragging has begun!

  if HaveThisFormat(formatetcIn) then begin

    // for this list we would normally ask the FileDragSource component
    // once its all completely implemented but for now I just quickly
    // make up a list of filenames myself.
    FileList := TStringList.Create;
    FileList.Append('c:\dummy.txt');
    FileList.Append('c:\dummy2.txt');

    // First we need a widestring #0 sepatated and #0#0 at the end.
    for FileName in FileList do begin
      sFileList += FileName + #0;
    end;
    sFileList += #0;
    FileList.Free;

    // now we need to allocate memory for the DROPFILES structure
    // we need room for that structure plus the above widestring
    BufLen := SizeOf(DROPFILES) + 2*Length(sFileList); //widestring!
    hgDropFiles := GlobalAlloc(GMEM_MOVEABLE or GMEM_DDESHARE or
GMEM_ZEROINIT, BufLen);

    // populate the DROPFILES structure,
    // it has the string of filenames appended directly at the end
    pgDropFiles := GlobalLock(hgDropFiles);
    pgDropFiles^.pFiles := SizeOf(DROPFILES); // offset of the file list
    pgDropFiles^.fWide := True; // contains widestring!
    Move(sFileList[1], pgDropFiles[1], 2*Length(sFileList)); // widestring!
    GlobalUnlock(hgDropFiles);

    // populate the STGMEDIUM structore;
    medium.Tymed := TYMED_HGLOBAL;
    medium.HGLOBAL := hgDropFiles;
    medium.PUnkForRelease := nil;

    Result := S_OK;
  end
  else
    Result := DV_E_FORMATETC;
end;

function TDataObject.GetDataHere(const pformatetc: FormatETC; out
medium: STGMEDIUM): HRESULT; STDCALL;
begin
end;

function TDataObject.QueryGetData(const pformatetc: FORMATETC):
HRESULT; STDCALL;
begin
  if HaveThisFormat(pformatetc) then
    Result := S_OK
  else
    Result := DV_E_FORMATETC;
end;

function TDataObject.GetCanonicalFormatEtc(const pformatetcIn:
FORMATETC; out pformatetcOut: FORMATETC): HResult; STDCALl;
begin
end;

function TDataObject.SetData(const pformatetc: FORMATETC; const
medium: STGMEDIUM; FRelease: BOOL): HRESULT; StdCall;
begin
end;

function TDataObject.EnumFormatEtc(dwDirection: DWord; out
enumformatetcpara: IENUMFORMATETC): HRESULT; StdCall;
var
  E: IEnumFORMATETC;
begin
  if dwDirection = DATADIR_GET then
    Result := SHCreateStdEnumFmtEtc(1, @MyFileDragFormat, enumformatetcpara)
  else
    Result := E_NOTIMPL;
end;

function TDataObject.DAdvise(const formatetc: FORMATETC; advf: DWORD;
const AdvSink: IAdviseSink; out dwConnection: DWORD): HRESULT;
StdCall;
begin
  Result := OLE_E_ADVISENOTSUPPORTED;
end;

function TDataObject.DUnadvise(dwconnection: DWord): HRESULT; StdCall;
begin
  Result := OLE_E_ADVISENOTSUPPORTED;
end;

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

function TDataObject.HaveThisFormat(const f: TFORMATETC): Boolean;
begin
  if (f.tymed = MyFileDragFormat.tymed)
  and (f.CfFormat = MyFileDragFormat.CfFormat)
  and (f.dwAspect = MyFileDragFormat.dwAspect) then
    Result := True
  else
    Result := False;
end;

{ TDragSource }

function TDropSource.QueryContinueDrag(fEscapePressed: BOOL;
grfKeyState: DWORD): HResult; StdCall;
begin
  // if the Escape key has been pressed since the last call, cancel the drop
  if fEscapePressed = True then
    exit(DRAGDROP_S_CANCEL);

  // if the LeftMouse button has been released, then do the drop!
  if (grfKeyState and MK_LBUTTON) = 0 then
    exit(DRAGDROP_S_DROP);

  // continue with the drag-drop
  Result := S_OK;
end;

function TDropSource.GiveFeedback(dwEffect: DWORD): HResult; StdCall;
begin
  Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;

initialization
  OleInitialize(nil);
finalization
  OleUninitialize();
end.