unit UnitDragClip;

interface

uses Windows, SysUtils, Classes, ShlObj, OLE2, UnitClipQueue;

type TDragResult = (drInvalid, drCancelled, drDropped);



function Execute(ci : TClipItem): TDragResult;


implementation

uses UnitMisc, UnitDropFile, System.Generics.Collections, UnitFrmDebug;

type
TDCDataObject = class(IDataObject)
    private
        fRefCount: integer;
        fci: TClipItem;
    public
        function QueryInterface(const iid: TIID; var obj): HResult; override; stdcall;
        function AddRef: Longint; override; stdcall;
        function Release: Longint; override; stdcall;
        function GetData(var formatetc: TFormatEtc; var medium: TStgMedium): HResult; override; stdcall;
        function GetDataHere(var formatetc: TFormatEtc; var medium: TStgMedium): HResult; override; stdcall;
        function QueryGetData(var formatetc: TFormatEtc): HResult; override; stdcall;
        function GetCanonicalFormatEtc(var formatetc: TFormatEtc; var formatetcOut: TFormatEtc): HResult; override; stdcall;
        function SetData(var formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult; override; stdcall;
        function EnumFormatEtc(dwDirection: Longint; var enumFormatEtc: IEnumFormatEtc): HResult; override; stdcall;
        function DAdvise(var formatetc: TFormatEtc; advf: Longint; advSink: IAdviseSink; var dwConnection: Longint): HResult; override; stdcall;
        function DUnadvise(dwConnection: Longint): HResult; override; stdcall;
        function EnumDAdvise(var enumAdvise: IEnumStatData): HResult; override; stdcall;
        constructor Create(ci : TClipItem);
end;
TDCEnum = class(IEnumFormatEtc)
    private
        FRefCount: integer;
        FIndex: integer;
        fci : TClipItem;
    public
        function QueryInterface(const iid: TIID; var obj): HResult; override; stdcall;
        function AddRef: Longint; override; stdcall;
        function Release: Longint; override; stdcall;
        function Next(celt: Longint; var elt; pceltFetched: PLongint): HResult; override; stdcall;
        function Skip(celt: Longint): HResult; override; stdcall;
        function Reset: HResult; override; stdcall;
        function Clone(var enum: IEnumFormatEtc): HResult; override; stdcall;
        constructor Create(ci : TClipItem);
end;
TDCDropSource = class(IDropSource)
    private
        fRefCount: integer;
        fDropEffect: longint;
    public
        function QueryInterface(const iid: TIID; var obj): HResult; override; stdcall;
        function AddRef: Longint; override; stdcall;
        function Release: Longint; override; stdcall;
        function QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; override; stdcall;
        function GiveFeedback(dwEffect: Longint): HResult; override; stdcall;
        constructor Create();
end;

const HDROP_SUPPORT = true;

var fFormats : array[0..3] of integer;
procedure SetFormats(ci : TClipItem);
var i : integer;
begin
    if ci.GetFormatType = FT_PICTURE then begin
        i := 0;
        fformats[i] := ci.GetFormat;
        inc(i);
        if HDROP_SUPPORT then begin
            fformats[i] := CF_HDROP;
            inc(i);
        end;
        fformats[i] := 0;
    end else begin
        fformats[0] := CF_TEXT;
        fformats[1] := CF_UNICODETEXT;
        i := 2;
        if ci.GetFormatType <> FT_UNICODE then begin
            fformats[i] := ci.GetFormat;
            inc(i);
        end;
        if HDROP_SUPPORT then begin
            fformats[i] := CF_HDROP;
            inc(i);
        end;

        if i <= High(fformats) then begin
            fformats[i] := 0;
        end;
    end;
end;

function Execute(ci : TClipItem): TDragResult;
var
    dwEffect: Longint;
    DropSource: TDCDropSource;
    Dataobject: TDCDataObject;
    i : integer;
begin
    Result := drInvalid;
    try
        SetFormats(ci);
        DataObject := TDCDataObject.create(ci);
        DataObject.AddRef;
        try
            DropSource := TDCDropSource.create;
            DropSource.AddRef;
            result := drCancelled;
            dwEffect := DROPEFFECT_NONE;
            i := DoDragDrop(dataobject, dropsource, DROPEFFECT_COPY, dwEffect);
            if (i = DRAGDROP_S_DROP) and (dwEffect = DROPEFFECT_COPY) then begin
                Result := drDropped
            end;
            DropSource.release;
        finally
            DataObject.release;
        end;
    except
    end;
end;


 { TMyDataObject }
constructor TDCDataObject.Create(ci : TClipItem);
begin
    inherited Create;
    fci := ci;
end;
function TDCDataObject.QueryInterface(const iid: TIID; var obj): HResult; stdcall;
begin
    Pointer(obj) := nil;
    result := E_NOINTERFACE;

    if IsEqualIID(iid, IID_IUnknown) or IsEqualIID(iid, IID_IDataObject) then begin
        Pointer(obj) := self;
        AddRef;
        Result := S_OK;
    end;
end;

function TDCDataObject.EnumFormatEtc(dwDirection: Longint; var enumFormatEtc: IEnumFormatEtc): HResult; stdcall;
begin
    enumFormatEtc := nil;
    result := E_NOTIMPL;
    if dwDirection = DATADIR_GET then begin
        enumFormatEtc := TDCEnum.Create(fci);
        enumFormatEtc.AddRef;
        result := S_OK;
    end;
end;
function TDCDataObject.QueryGetData(var formatetc: TFormatEtc): HResult; stdcall;
var i : integer;
begin
    Result := DV_E_FORMATETC;

    if (formatetc.dwAspect = DVASPECT_CONTENT) and
        ((formatetc.tymed and TYMED_HGLOBAL)<>0) and
        (formatetc.lindex = -1) and
        (formatetc.ptd = nil)
        then begin

        for i in fFormats do begin
            if i = 0 then EXIT;
            if formatetc.cfFormat = i then begin
                result := S_OK;
                FrmDebug.AppendLog('DragClip - Query ' + IntToStr(formatetc.cfFormat));
                EXIT;
            end;
        end;
    end;
end;
function TDCDataObject.GetData(var formatetc: TFormatEtc; var medium: TStgMedium): HResult; stdcall;
var
    s : string;
    astr : AnsiString;
begin
    Result := DV_E_FORMATETC;
    if QueryGetData(formatetc) <> S_OK then  EXIT;

    FrmDebug.AppendLog('DragClip - GetData Starting ' + IntToStr(formatetc.cfFormat));
    // most medium fields are already initialized by this point
    medium.tymed := TYMED_HGLOBAL;

    case formatetc.cfFormat of
    CF_TEXT:
        begin
            astr := fci.GetAsPlaintext + #0;
            medium.hGlobal := UnitMisc.DupPointerToHandle(@astr[1], length(astr) );
            FrmDebug.AppendLog('DragClip - as Text');
        end;
    CF_UNICODETEXT:
        begin
            s := fci.GetAsPlaintext + #0;
            medium.hGlobal := UnitMisc.DupPointerToHandle(@s[1], length(s) * SizeOf(Char) );
            FrmDebug.AppendLog('DragClip - as Unicode');
        end;
    CF_HDROP:
        begin
            if fci.GetFormatType = FT_FILE then begin
                medium.hGlobal := UnitMisc.DupStreamToHandle(fci.GetStream);
                fci.FinishedWithStream;
                FrmDebug.AppendLog('DragClip - as HDROP Files');
            end else begin
                UnitDropFile.DropFileHandle(fci, medium.hGlobal);
                FrmDebug.AppendLog('DragClip - as Files');
            end;
        end;
    else
        begin
            medium.hGlobal := UnitMisc.DupStreamToHandle(fci.GetStream);
            fci.FinishedWithStream;
            FrmDebug.AppendLog('DragClip - as Clip');
        end;
    end;
    medium.unkForRelease := nil;

    result := S_OK;
end;

function TDCDataObject.AddRef: Longint; stdcall;
begin
    Inc(FRefCount);
    result := FRefCount;
end;
function TDCDataObject.Release: Longint; stdcall;
begin
    Dec(FRefCount);
    Result := FRefCount;
    if FRefCount = 0 then
        self.Free;
end;
function TDCDataObject.GetDataHere(var formatetc: TFormatEtc; var medium: TStgMedium): HResult; stdcall;
begin
    FrmDebug.AppendLog('DragClip - GetDataHere');
    result := E_NOTIMPL;
end;
function TDCDataObject.GetCanonicalFormatEtc(var formatetc: TFormatEtc; var formatetcOut: TFormatEtc): HResult; stdcall;
begin
    FrmDebug.AppendLog('DragClip - GetCanonicalFormatEtc');

    formatetcOut.cfFormat := CF_UNICODETEXT;
	formatetcOut.ptd := 0;
	formatetcOut.dwAspect := DVASPECT_CONTENT;
	formatetcOut.lindex := -1;
	formatetcOut.tymed := TYMED_HGLOBAL;
	result := S_OK;
end;
function TDCDataObject.SetData(var formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult; stdcall;
begin
    result := E_NOTIMPL;
end;
function TDCDataObject.DAdvise(var formatetc: TFormatEtc; advf: Longint; advSink: IAdviseSink; var dwConnection: Longint): HResult; stdcall;
begin
    result := E_NOTIMPL;
end;
function TDCDataObject.DUnadvise(dwConnection: Longint): HResult; stdcall;
begin
    result := E_NOTIMPL;
end;
function TDCDataObject.EnumDAdvise(var enumAdvise: IEnumStatData): HResult; stdcall;
begin
    result := E_NOTIMPL;
end;

constructor TDCEnum.Create(ci : TClipItem);
begin
    inherited Create;
    fci := ci;
end;
function TDCEnum.QueryInterface(const iid: TIID; var obj): HResult; stdcall;
begin
    Pointer(obj) := nil;
    result := E_NOINTERFACE;

    if IsEqualIID(iid, IID_IUnknown) or IsEqualIID(iid, IID_IEnumFormatEtc) then begin
        Pointer(obj) := self;
        AddRef;
        result := S_OK;
    end;
end;

function TDCEnum.Next(celt: Longint; var elt; pceltFetched: PLongint): HResult; stdcall;
type TFormatEtcArray = array[0..3] of TFormatEtc;
var FormatEtcArrayOut : TFormatEtcArray absolute elt;

    procedure SetFormat(f : word; i : integer);
    begin
        FrmDebug.AppendLog('DragClip - Next format=' + IntToSTr(f));
        with FormatEtcArrayOut[i] do begin
            cfFormat := f;
            ptd := nil;
            dwAspect := DVASPECT_CONTENT;
            lIndex := -1;
            tymed := TYMED_HGLOBAL;
        end;
    end;
    procedure SetReturnedCount(c : integer);
    begin
         if Assigned(pceltFetched) then
            pceltFetched^ := c;
    end;
var
    x : Pointer;
    i : integer;
    cnt : integer;
begin
//    FrmDebug.AppendLog('DragClip - Next=' + IntToStr(celt) + ' index='+IntToStr(findex));
    result := S_FALSE;
    SetReturnedCount(0);

    if celt < 1 then EXIT;
    if fIndex > high(fformats) then EXIT;

    cnt := 0;
    for i := 1 to Celt do begin
        if fIndex > high(fformats) then BREAK;
        if fformats[fIndex] = 0 then BREAK;

        SetFormat(fformats[fIndex], cnt);
        Inc(fIndex);
        inc(cnt);
    end;

    SetReturnedCount(cnt);
    if cnt > 0 then begin
        result := S_OK;
    end;

//    FrmDebug.AppendLog('DragClip - Next OK');
end;


function TDCEnum.AddRef: Longint; stdcall;
begin
    Inc(FRefCount);
    result := FRefCount;
end;
function TDCEnum.Release: Longint; stdcall;
begin
    Dec(FRefCount);
    result := FRefCount;
    if FRefCount = 0 then
        Free;
end;
function TDCEnum.Skip(celt: Longint): HResult; stdcall;
begin
    Inc(fIndex, celt);
    Result := S_OK;
    if FIndex > 1 then begin
        result := S_FALSE
    end;
end;
function TDCEnum.Reset: HResult; stdcall;
begin
    fIndex := 0;
    Result := S_OK;
end;
function TDCEnum.Clone(var enum: IEnumFormatEtc): HResult; stdcall;
begin
    enum := TDCEnum.Create(fci);
    enum.AddRef;
    TDCEnum(enum).FIndex := FIndex;
    result := S_OK;
end;



constructor TDCDropSource.Create;
begin
    inherited Create;
end;
function TDCDropSource.QueryInterface(const iid: TIID; var obj): HResult; stdcall;
begin
    Pointer(obj) := nil;
    result := E_NOINTERFACE;

    if IsEqualIID(iid, IID_IUnknown) or IsEqualIID(iid, IID_IDropSource) then begin
        Pointer(obj) := self;
        AddRef;
        result := S_OK;
    end;
end;
function TDCDropSource.AddRef: Longint; stdcall;
begin
    Inc(FRefCount);
    result := FRefCount;
end;
function TDCDropSource.Release: Longint; stdcall;
begin
    Dec(FRefCount);
    Result := FRefCount;
    if fRefCount = 0 then
        self.Free;
end;
function TDCDropSource.QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; stdcall;
begin
    result := S_OK;
    if fEscapePressed then begin
        result := DRAGDROP_S_CANCEL;
    end else if (grfKeyState and MK_LBUTTON) = 0 then begin
        result := DRAGDROP_S_DROP;
        FrmDebug.AppendLog('DragClip - Mouse Up');
    end;
end;
function TDCDropSource.GiveFeedback(dwEffect: Longint): HResult; stdcall;
begin
    fDropEffect := dwEffect;
    result := DRAGDROP_S_USEDEFAULTCURSORS;
end;




initialization
OleInitialize(nil);

finalization
OleUninitialize;
end.
