summaryrefslogtreecommitdiff
path: root/src/corelib
diff options
context:
space:
mode:
Diffstat (limited to 'src/corelib')
-rw-r--r--src/corelib/gdi/fpg_oledragdrop.pas922
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.
+
generated by cgit v1.2.3-70-g09d2 (git 2.47.1) at 2024-12-28 06:41:04 +0000