diff options
author | Graeme Geldenhuys <graeme@mastermaths.co.za> | 2012-11-22 11:48:47 +0000 |
---|---|---|
committer | Graeme Geldenhuys <graeme@mastermaths.co.za> | 2012-11-22 11:48:47 +0000 |
commit | af45f95f16cee22f8f012f706f4d0a42eaeb68fa (patch) | |
tree | c572c1cc6a7d3bb12874d8f9b9363312b275e328 /src/corelib/gdi/fpg_oledragdrop.pas | |
parent | 9c62dfaf7217557f08a3d33b20bb302874960f87 (diff) | |
download | fpGUI-af45f95f16cee22f8f012f706f4d0a42eaeb68fa.tar.xz |
Fixes line ending issues
Diffstat (limited to 'src/corelib/gdi/fpg_oledragdrop.pas')
-rw-r--r-- | src/corelib/gdi/fpg_oledragdrop.pas | 2148 |
1 files changed, 1074 insertions, 1074 deletions
diff --git a/src/corelib/gdi/fpg_oledragdrop.pas b/src/corelib/gdi/fpg_oledragdrop.pas index 36eed0a5..11798bb6 100644 --- a/src/corelib/gdi/fpg_oledragdrop.pas +++ b/src/corelib/gdi/fpg_oledragdrop.pas @@ -1,1074 +1,1074 @@ -{
- 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.
- This unit is implemented based on the articles posted on
- http://www.catch22.net/tuts/dragdrop/
-}
-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 }
- {$IF FPC_FULLVERSION>=20601}
- function QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: DWORD):HResult; StdCall;
- function GiveFeedback(dwEffect: DWORD): HResult; StdCall;
- {$ELSE}
- function QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; stdcall;
- function GiveFeedback(dwEffect: longint): HResult; stdcall;
- {$ENDIF}
- end;
-
-
- TfpgOLEDragDropEffect = (deNone, deCopy, deMove, deLink);
- TfpgOLEDragEnterEvent = procedure(Sender: TObject; DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: DWORD) 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;
- private
- { IInterface }
- function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid: TGuid; out obj): LongInt; stdcall;
- function _AddRef: longint; stdcall;
- function _Release: longint; 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;
- protected
- procedure DoDragEnter(DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: DWORD); virtual;
- procedure DoDragOver(KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); virtual;
- procedure DoDragLeave;
- procedure DoDragDrop(DataObj: IDataObject; KeyState: Longint; PT: TPoint; Effect: TfpgOLEDragDropEffect); virtual;
- public
- 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: DWORD); 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;
-
-
-function WindowsMimeLookup(const CFFormat: string): string;
-function WindowsClipboardLookup(const AMime: string; var IsTranslated: Boolean): DWORD;
-function EnumDataToStringList(DataObj: IDataObject): TStringList;
-function GetFormatEtc(const CFFormat: DWORD): FORMATETC;
-
-implementation
-
-uses
- SysUtils, ShlObj, fpg_widget;
-
-var
- CF_FILENAMEMAP: Cardinal;
- CF_FILEDESCRIPTOR: Cardinal;
- CF_FILECONTENTS: Cardinal;
-
-
-function WindowsMimeLookup(const CFFormat: string): string;
-begin
- { replace known clipboard formats with mime types }
- if CFFormat = 'CF_TEXT' then
- Result := 'text/plain'
- else if CFFormat = 'CF_UNICODETEXT' then
- Result := 'text/plain'
- else if CFFormat = 'CF_OEMTEXT' then
- Result := 'text/plain'
- else if CFFormat = 'CF_HDROP' then
- Result := 'text/uri-list'
- else if CFFormat = 'CF_RICHTEXT' then
- Result := 'text/html'
- else
- Result := CFFormat;
-end;
-
-function WindowsClipboardLookup(const AMime: string; var IsTranslated: Boolean): DWORD;
-begin
- { TODO: We need to improve this implementation }
- if AMime = 'text/html' then
- begin
- { We don't want duplicate CF_TEXT in DataObject, so register some of our
- known convenience types (from TfpgMimeData) as-is }
- IsTranslated := False;
- Result := RegisterClipboardFormat('text/html');
- end
- else if Pos('text/', AMime) = 1 then
- begin
- IsTranslated := True;
- Result := CF_TEXT; // fallback result
- end
- else
- begin
- IsTranslated := False;
- Result := RegisterClipboardFormat(PChar(AMime));
- end;
-end;
-
-function WindowsClipboardFormatToString(const CFFormat: integer): string;
-begin
- { replace know clipboard formats with mime types }
- case CFFormat of
- CF_DIF : result := 'CF_DIF';
- CF_DIB : result := 'CF_DIB';
- CF_TEXT : result := 'CF_TEXT';
- CF_SYLK : result := 'CF_SYLK';
- CF_TIFF : result := 'CF_TIFF';
- CF_RIFF : result := 'CF_RIFF';
- CF_WAVE : result := 'CF_WAVE';
- CF_HDROP : result := 'CF_HDROP';
- CF_BITMAP : result := 'CF_BITMAP';
- CF_LOCALE : result := 'CF_LOCALE';
- CF_OEMTEXT : result := 'CF_OEMTEXT';
- CF_PALETTE : result := 'CF_PALETTE';
- CF_PENDATA : result := 'CF_PENDATA';
- CF_UNICODETEXT : result := 'CF_UNICODETEXT';
- CF_ENHMETAFILE : result := 'CF_ENHMETAFILE';
- CF_METAFILEPICT : result := 'CF_METAFILEPICT';
- else
- Result := Format('unknown (%d)', [CFFormat]);
- end;
-end;
-
-function EnumDataToStringList(DataObj: IDataObject): TStringList;
-var
- FE: FORMATETC;
- EnumFormats: IEnumFORMATETC;
- num: integer;
- lname: string;
- lMimeName: string;
- FormatName: array[0..MAX_PATH] of Char;
- i: integer;
-begin
- if DataObj.EnumFormatEtc(DATADIR_GET, EnumFormats) <> S_OK then
- raise Exception.Create('EnumDataToStringList: Failed to get EnumFormatEtc interface');
-
- Result := TStringList.Create;
- EnumFormats.Reset;
- while EnumFormats.Next(1, FE, @num) = S_OK do
- begin
- lName := '';
- i := GetClipboardFormatName(FE.cfFormat,FormatName,MAX_PATH);
- if i <> 0 then
- begin
- lName := FormatName;
- end
- else
- begin
- lName := WindowsClipboardFormatToString(FE.cfFormat);
- end;
- Result.Add(lName);
- end;
-end;
-
-function GetFormatEtc(const CFFormat: DWORD): FORMATETC;
-begin
- Result.CfFormat := CFFormat;
- Result.Ptd := nil;
- Result.dwAspect := DVASPECT_CONTENT;
- Result.lindex := -1;
- Result.tymed := TYMED_HGLOBAL;
-end;
-
-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;
-
- { append filenames as one long string delimited by #0. ie: something like a PChar }
- 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;
-
- { description of data we are sending }
- New(F);
- F^.cfFormat := CF_HDROP;
- F^.ptd := nil;
- F^.dwAspect := DVASPECT_CONTENT;
- F^.lindex := -1;
- F^.tymed := TYMED_HGLOBAL;
- DataObject.FormatEtcList.Add(F);
-
- { storage for data we are sending }
- 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
- { append filename aliases as one long string delimited by #0. ie: something like a PChar }
- 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;
-
- { description of data we are sending }
- New(F);
- F^.cfFormat := CF_FILENAMEMAP;
- F^.ptd := nil;
- F^.dwAspect := DVASPECT_CONTENT;
- F^.lindex := -1;
- F^.tymed := TYMED_HGLOBAL;
- DataObject.FormatEtcList.Add(F);
-
- { storage for data we are sending }
- 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
- // nothing to do. If this whas xxx_MOVE, we would remove data from source
- 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 }
-
-{$IF FPC_FULLVERSION>=20601}
-function TfpgOLEDropSource.GiveFeedback(dwEffect: DWORD): HResult;
-{$ELSE}
-function TfpgOLEDropSource.GiveFeedback(dwEffect: longint): HResult;
-{$ENDIF}
-begin
- Result := DRAGDROP_S_USEDEFAULTCURSORS;
-end;
-
-{$IF FPC_FULLVERSION>=20601}
-function TfpgOLEDropSource.QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: DWORD):HResult;
-{$ELSE}
-function TfpgOLEDropSource.QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: LongInt): HResult;
-{$ENDIF}
-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;
- {$IFDEF DND_DEBUG}
- writeln('TfpgOLEDropSource.QueryContinueDrag Result = ', Result);
- {$ENDIF}
-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, dwEffect);
- //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;
- DoDragLeave;
-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: longint;
-begin
- Result := 1;
-end;
-
-function TfpgOLEDropTarget._Release: longint;
-begin
- Result := 1;
-end;
-
-function TfpgOLEDropTarget.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid: TGuid; out obj): longint; stdcall;
-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: LongInt; PT: TPoint; var Effect: DWORD);
-begin
- if Assigned(FOnDragEnter) then begin
- FOnDragEnter(Self, DataObj, KeyState, PT, Effect);
- end;
-end;
-
-procedure TfpgOLEDropTarget.DoDragOver(KeyState: LongInt; PT: TPoint;
- var Effect: TfpgOLEDragDropEffect);
-begin
- if Assigned(FOnDragOver) then begin
- FOnDragOver(Self, KeyState, PT, Effect);
- end;
-end;
-
-procedure TfpgOLEDropTarget.DoDragLeave;
-begin
- if Assigned(FOnDragLeave) then
- FOnDragLeave(self);
-end;
-
-procedure TfpgOLEDropTarget.DoDragDrop(DataObj: IDataObject; KeyState: LongInt;
- 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: LongInt; PT: TPoint; var Effect: DWORD);
-begin
- FDragAcceptFiles := DoDragAcceptFiles(DataObj);
- if FDragAcceptFiles and DoDragAcceptPosition(PT) then
- inherited DoDragEnter(DataObj, KeyState, PT, Effect)
- else
- Effect := DROPEFFECT_NONE;
-end;
-
-procedure TDragFilesTarget.DoDragOver(KeyState: LongInt; PT: TPoint; var Effect: TfpgOLEDragDropEffect);
-begin
- if FDragAcceptFiles and DoDragAcceptPosition(PT) then
- inherited DoDragOver(KeyState, PT, Effect)
- else
- Effect := deNone;
-end;
-
-procedure TDragFilesTarget.DoDragDrop(DataObj: IDataObject;
- KeyState: LongInt; 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.
-
+{ + 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. + This unit is implemented based on the articles posted on + http://www.catch22.net/tuts/dragdrop/ +} +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 } + {$IF FPC_FULLVERSION>=20601} + function QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: DWORD):HResult; StdCall; + function GiveFeedback(dwEffect: DWORD): HResult; StdCall; + {$ELSE} + function QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; stdcall; + function GiveFeedback(dwEffect: longint): HResult; stdcall; + {$ENDIF} + end; + + + TfpgOLEDragDropEffect = (deNone, deCopy, deMove, deLink); + TfpgOLEDragEnterEvent = procedure(Sender: TObject; DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: DWORD) 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; + private + { IInterface } + function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid: TGuid; out obj): LongInt; stdcall; + function _AddRef: longint; stdcall; + function _Release: longint; 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; + protected + procedure DoDragEnter(DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: DWORD); virtual; + procedure DoDragOver(KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); virtual; + procedure DoDragLeave; + procedure DoDragDrop(DataObj: IDataObject; KeyState: Longint; PT: TPoint; Effect: TfpgOLEDragDropEffect); virtual; + public + 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: DWORD); 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; + + +function WindowsMimeLookup(const CFFormat: string): string; +function WindowsClipboardLookup(const AMime: string; var IsTranslated: Boolean): DWORD; +function EnumDataToStringList(DataObj: IDataObject): TStringList; +function GetFormatEtc(const CFFormat: DWORD): FORMATETC; + +implementation + +uses + SysUtils, ShlObj, fpg_widget; + +var + CF_FILENAMEMAP: Cardinal; + CF_FILEDESCRIPTOR: Cardinal; + CF_FILECONTENTS: Cardinal; + + +function WindowsMimeLookup(const CFFormat: string): string; +begin + { replace known clipboard formats with mime types } + if CFFormat = 'CF_TEXT' then + Result := 'text/plain' + else if CFFormat = 'CF_UNICODETEXT' then + Result := 'text/plain' + else if CFFormat = 'CF_OEMTEXT' then + Result := 'text/plain' + else if CFFormat = 'CF_HDROP' then + Result := 'text/uri-list' + else if CFFormat = 'CF_RICHTEXT' then + Result := 'text/html' + else + Result := CFFormat; +end; + +function WindowsClipboardLookup(const AMime: string; var IsTranslated: Boolean): DWORD; +begin + { TODO: We need to improve this implementation } + if AMime = 'text/html' then + begin + { We don't want duplicate CF_TEXT in DataObject, so register some of our + known convenience types (from TfpgMimeData) as-is } + IsTranslated := False; + Result := RegisterClipboardFormat('text/html'); + end + else if Pos('text/', AMime) = 1 then + begin + IsTranslated := True; + Result := CF_TEXT; // fallback result + end + else + begin + IsTranslated := False; + Result := RegisterClipboardFormat(PChar(AMime)); + end; +end; + +function WindowsClipboardFormatToString(const CFFormat: integer): string; +begin + { replace know clipboard formats with mime types } + case CFFormat of + CF_DIF : result := 'CF_DIF'; + CF_DIB : result := 'CF_DIB'; + CF_TEXT : result := 'CF_TEXT'; + CF_SYLK : result := 'CF_SYLK'; + CF_TIFF : result := 'CF_TIFF'; + CF_RIFF : result := 'CF_RIFF'; + CF_WAVE : result := 'CF_WAVE'; + CF_HDROP : result := 'CF_HDROP'; + CF_BITMAP : result := 'CF_BITMAP'; + CF_LOCALE : result := 'CF_LOCALE'; + CF_OEMTEXT : result := 'CF_OEMTEXT'; + CF_PALETTE : result := 'CF_PALETTE'; + CF_PENDATA : result := 'CF_PENDATA'; + CF_UNICODETEXT : result := 'CF_UNICODETEXT'; + CF_ENHMETAFILE : result := 'CF_ENHMETAFILE'; + CF_METAFILEPICT : result := 'CF_METAFILEPICT'; + else + Result := Format('unknown (%d)', [CFFormat]); + end; +end; + +function EnumDataToStringList(DataObj: IDataObject): TStringList; +var + FE: FORMATETC; + EnumFormats: IEnumFORMATETC; + num: integer; + lname: string; + lMimeName: string; + FormatName: array[0..MAX_PATH] of Char; + i: integer; +begin + if DataObj.EnumFormatEtc(DATADIR_GET, EnumFormats) <> S_OK then + raise Exception.Create('EnumDataToStringList: Failed to get EnumFormatEtc interface'); + + Result := TStringList.Create; + EnumFormats.Reset; + while EnumFormats.Next(1, FE, @num) = S_OK do + begin + lName := ''; + i := GetClipboardFormatName(FE.cfFormat,FormatName,MAX_PATH); + if i <> 0 then + begin + lName := FormatName; + end + else + begin + lName := WindowsClipboardFormatToString(FE.cfFormat); + end; + Result.Add(lName); + end; +end; + +function GetFormatEtc(const CFFormat: DWORD): FORMATETC; +begin + Result.CfFormat := CFFormat; + Result.Ptd := nil; + Result.dwAspect := DVASPECT_CONTENT; + Result.lindex := -1; + Result.tymed := TYMED_HGLOBAL; +end; + +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; + + { append filenames as one long string delimited by #0. ie: something like a PChar } + 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; + + { description of data we are sending } + New(F); + F^.cfFormat := CF_HDROP; + F^.ptd := nil; + F^.dwAspect := DVASPECT_CONTENT; + F^.lindex := -1; + F^.tymed := TYMED_HGLOBAL; + DataObject.FormatEtcList.Add(F); + + { storage for data we are sending } + 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 + { append filename aliases as one long string delimited by #0. ie: something like a PChar } + 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; + + { description of data we are sending } + New(F); + F^.cfFormat := CF_FILENAMEMAP; + F^.ptd := nil; + F^.dwAspect := DVASPECT_CONTENT; + F^.lindex := -1; + F^.tymed := TYMED_HGLOBAL; + DataObject.FormatEtcList.Add(F); + + { storage for data we are sending } + 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 + // nothing to do. If this whas xxx_MOVE, we would remove data from source + 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 } + +{$IF FPC_FULLVERSION>=20601} +function TfpgOLEDropSource.GiveFeedback(dwEffect: DWORD): HResult; +{$ELSE} +function TfpgOLEDropSource.GiveFeedback(dwEffect: longint): HResult; +{$ENDIF} +begin + Result := DRAGDROP_S_USEDEFAULTCURSORS; +end; + +{$IF FPC_FULLVERSION>=20601} +function TfpgOLEDropSource.QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: DWORD):HResult; +{$ELSE} +function TfpgOLEDropSource.QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: LongInt): HResult; +{$ENDIF} +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; + {$IFDEF DND_DEBUG} + writeln('TfpgOLEDropSource.QueryContinueDrag Result = ', Result); + {$ENDIF} +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, dwEffect); + //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; + DoDragLeave; +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: longint; +begin + Result := 1; +end; + +function TfpgOLEDropTarget._Release: longint; +begin + Result := 1; +end; + +function TfpgOLEDropTarget.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid: TGuid; out obj): longint; stdcall; +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: LongInt; PT: TPoint; var Effect: DWORD); +begin + if Assigned(FOnDragEnter) then begin + FOnDragEnter(Self, DataObj, KeyState, PT, Effect); + end; +end; + +procedure TfpgOLEDropTarget.DoDragOver(KeyState: LongInt; PT: TPoint; + var Effect: TfpgOLEDragDropEffect); +begin + if Assigned(FOnDragOver) then begin + FOnDragOver(Self, KeyState, PT, Effect); + end; +end; + +procedure TfpgOLEDropTarget.DoDragLeave; +begin + if Assigned(FOnDragLeave) then + FOnDragLeave(self); +end; + +procedure TfpgOLEDropTarget.DoDragDrop(DataObj: IDataObject; KeyState: LongInt; + 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: LongInt; PT: TPoint; var Effect: DWORD); +begin + FDragAcceptFiles := DoDragAcceptFiles(DataObj); + if FDragAcceptFiles and DoDragAcceptPosition(PT) then + inherited DoDragEnter(DataObj, KeyState, PT, Effect) + else + Effect := DROPEFFECT_NONE; +end; + +procedure TDragFilesTarget.DoDragOver(KeyState: LongInt; PT: TPoint; var Effect: TfpgOLEDragDropEffect); +begin + if FDragAcceptFiles and DoDragAcceptPosition(PT) then + inherited DoDragOver(KeyState, PT, Effect) + else + Effect := deNone; +end; + +procedure TDragFilesTarget.DoDragDrop(DataObj: IDataObject; + KeyState: LongInt; 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. + |