From f436c95222de7300653a43875c481dd30e05e7ee Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Mon, 18 Oct 2010 17:10:13 +0200 Subject: GDI: A near complete Windows OLE Drag-n-Drop implementation --- src/corelib/gdi/fpg_oledragdrop.pas | 922 ++++++++++++++++++++++++++++++++++++ 1 file changed, 922 insertions(+) create mode 100644 src/corelib/gdi/fpg_oledragdrop.pas (limited to 'src/corelib/gdi') 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. + -- cgit v1.2.3-70-g09d2