1 unit virtualdragmanager;
2 {fake unit just to compile - not used under non windows}
3
4 {$mode delphi}
5
6 interface
7
8 uses
9 Classes, SysUtils, Types;
10
11 const
12 // Drag image helpers for Windows 2000 and up.
13 IID_IDropTargetHelper: TGUID = (D1: $4657278B; D2: $411B; D3: $11D2; D4: ($83, $9A, $00, $C0, $4F, $D9, $18, $D0));
14 IID_IDragSourceHelper: TGUID = (D1: $DE5BF786; D2: $477A; D3: $11D2; D4: ($83, $9D, $00, $C0, $4F, $D9, $18, $D0));
15 IID_IDropTarget: TGUID = (D1: $00000122; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46));
16 CLSID_DragDropHelper: TGUID = (D1: $4657278A; D2: $411B; D3: $11D2; D4: ($83, $9A, $00, $C0, $4F, $D9, $18, $D0));
17
18 SID_IDropTargetHelper = '{4657278B-411B-11D2-839A-00C04FD918D0}';
19 SID_IDragSourceHelper = '{DE5BF786-477A-11D2-839D-00C04FD918D0}';
20 SID_IDropTarget = '{00000122-0000-0000-C000-000000000046}';
21
22 //Bridge to ActiveX constants
23
24 TYMED_HGLOBAL = 1;
25 TYMED_ISTREAM = 4;
26 DVASPECT_CONTENT = 1;
27 CLSCTX_INPROC_SERVER = $0010;
28 DROPEFFECT_COPY = 1;
29 DROPEFFECT_LINK = 4;
30 DROPEFFECT_MOVE = 2;
31 DROPEFFECT_NONE = 0;
32 DROPEFFECT_SCROLL = dword($80000000);
33 DATADIR_GET = 1;
34
35 type
36 //types from win unit
37 Long = LongInt;
38 WinBool= LongBool;
39 Bool= WinBool;
40 ULONG = cardinal;
41 LONGLONG = int64;
42 LPDWORD = ^DWORD;
43 LPVOID = pointer;
44
45 TCOLORREF = cardinal;
46
47 TIID = TGUID;
48
49 LARGE_INTEGER = record
50 case byte of
51 0: (LowPart : DWORD;
52 HighPart : LONG);
53 1: (QuadPart : LONGLONG);
54 end;
55 PLARGE_INTEGER = ^LARGE_INTEGER;
56 _LARGE_INTEGER = LARGE_INTEGER;
57
58 TLargeInteger = Int64;
59 PLargeInteger = ^TLargeInteger;
60
61 ULARGE_INTEGER = record
62 case byte of
63 0: (LowPart : DWORD;
64 HighPart : DWORD);
65 1: (QuadPart : LONGLONG);
66 end;
67 PULARGE_INTEGER = ^ULARGE_INTEGER;
68 _ULARGE_INTEGER = ULARGE_INTEGER;
69
70
71 HANDLE = System.THandle;
72 HWND = HANDLE;
73 //HRESULT = System.HResult;
74
75 HBITMAP = HANDLE;
76 HENHMETAFILE = HANDLE;
77
78 //activex types
79
80
81 IMoniker = Interface;
82
83 WINOLEAPI = HResult;
84 TLCID = DWORD;
85
86 OleChar = WChar;
87 LPOLESTR = ^OLECHAR;
88 HMetaFilePict = Pointer;
89
90
91 tagBIND_OPTS = Record
92 cvStruct, // sizeof(BIND_OPTS)
93 grfFlags,
94 grfMode,
95 dwTickCountDeadline : DWord;
96 End;
97 TBind_Opts = tagBIND_OPTS;
98 TCLIPFORMAT = Word;
99
100 tagDVTARGETDEVICE = Record
101 tdSize : DWord;
102 tdDriverNameOffset,
103 tdDeviceNameOffset,
104 tdPortNameOffset,
105 tdExtDevmodeOffset : Word;
106 Data : Record End;
107 End;
108 DVTARGETDEVICE = TagDVTARGETDEVICE;
109 PDVTARGETDEVICE = ^tagDVTARGETDEVICE;
110
111
112
113 tagFORMATETC = Record
114 CfFormat : Word {TCLIPFORMAT};
115 Ptd : PDVTARGETDEVICE;
116 dwAspect : DWORD;
117 lindex : Long;
118 tymed : DWORD;
119 End;
120 FORMATETC = TagFORMATETC;
121 TFORMATETC = FORMATETC;
122 LPFORMATETC = ^FORMATETC;
123 PFormatEtc = LPFORMATETC;
124
125 tagSTATDATA = Record
126 // field used by:
127 FORMATETC : Tformatetc; // EnumAdvise, EnumData (cache), EnumFormats
128 advf : DWord; // EnumAdvise, EnumData (cache)
129 padvSink : Pointer {IAdviseSink}; // EnumAdvise
130 dwConnection: DWord; // EnumAdvise
131 End;
132 STATDATA = TagStatData;
133
134
135 TagSTGMEDIUM = Record
136 Tymed : DWord;
137 Case Integer Of
138 0 : (HBITMAP : hBitmap; PUnkForRelease : Pointer {IUnknown});
139 1 : (HMETAFILEPICT : hMetaFilePict );
140 2 : (HENHMETAFILE : hEnhMetaFile );
141 3 : (HGLOBAL : hGlobal );
142 4 : (lpszFileName : LPOLESTR );
143 5 : (pstm : Pointer{IStream} );
144 6 : (pstg : Pointer{IStorage} );
145 End;
146 USTGMEDIUM = TagSTGMEDIUM;
147 STGMEDIUM = USTGMEDIUM;
148 TStgMedium = TagSTGMEDIUM;
149 PStgMedium = ^TStgMedium;
150 LPSTGMEDIUM = ^STGMEDIUM;
151
152 IEnumString = Interface (IUnknown)
153 ['{00000101-0000-0000-C000-000000000046}']
Nextnull154 Function Next(Celt:ULong;Out xcelt;Out Celtfetched:ULong):HResult; StdCall;
RemoteNextnull155 // Function RemoteNext(Celt:ULong; Out celt;Out Celtfetched:ULong):HResult; StdCall;
156 Function Skip (Celt:ULong):Hresult;StdCall;
Resetnull157 Function Reset:HResult;StdCall;
Clonenull158 Function Clone(Out penum:IEnumString):HResult;StdCall;
159 End;
160
161
162 IEnumMoniker = Interface (IUnknown)
163 ['{00000102-0000-0000-C000-000000000046}']
Nextnull164 Function Next(celt:ULong; out Elt;out celftfetched: ULong):HResult; StdCall;
RemoteNextnull165 // Function RemoteNext(Celt:ULong; Out rgelt;out celtfetched :ULong):Hresult; StdCall;
166 Function Skip(celt:Ulong):HResult; StdCall;
Resetnull167 Function Reset:HResult; StdCall;
Closenull168 Function Close(out penum:IEnumMoniker):HResult;StdCall;
169 End;
170
171 IEnumSTATDATA = Interface (IUnknown)
172 ['{00000105-0000-0000-C000-000000000046}']
Nextnull173 Function Next(Celt:ULong;Out Rgelt:statdata;Out pceltFetched:ULong):HResult; StdCall;
RemoteNextnull174 // Function RemoteNext(Celt:ULong;Out Rgelt:statdata;Out pceltFetched:ULong):HResult; StdCall;
175 Function Skip(Celt:ULong):HResult;StdCall;
Resetnull176 Function Reset:HResult;StdCall;
Clonenull177 Function Clone(out penum:IEnumstatdata):HResult;StdCall;
178 End;
179
180 IEnumFORMATETC = Interface (IUnknown)
181 ['{00000103-0000-0000-C000-000000000046}']
Nextnull182 Function Next(Celt:ULong;Out Rgelt:FormatEtc;Out pceltFetched:ULong):HResult; StdCall;
RemoteNextnull183 // Function RemoteNext(Celt:ULong;Out Rgelt:FormatEtc;Out pceltFetched:ULong):HResult; StdCall;
184 Function Skip(Celt:ULong):HResult;StdCall;
Resetnull185 Function Reset:HResult;StdCall;
Clonenull186 Function Clone(out penum:IEnumFORMATETC):HResult;StdCall;
187 End;
188
189
190
191 IPersist = Interface (IUnknown)
192 ['{0000010c-0000-0000-C000-000000000046}']
GetClassIdnull193 Function GetClassId(clsid:TClsId):HResult; StdCall;
194 End;
195
196 IPersistStream = Interface(IPersist)
197 ['{00000109-0000-0000-C000-000000000046}']
IsDirtynull198 Function IsDirty:HResult; StdCall;
Loadnull199 Function Load(Const stm: IStream):HResult; StdCall;
Savenull200 Function Save(Const stm: IStream;fClearDirty:Bool):HResult;StdCall;
GetSizeMaxnull201 Function GetSizeMax(Out cbSize:ULarge_Integer):HResult; StdCall;
202 End;
203
204
205 IRunningObjectTable = Interface (IUnknown)
206 ['{00000010-0000-0000-C000-000000000046}']
Registernull207 Function Register (grfFlags :DWord;const unkobject:IUnknown;Const mkObjectName:IMoniker;Out dwregister:DWord):HResult;StdCall;
Revokenull208 Function Revoke (dwRegister:DWord):HResult; StdCall;
IsRunningnull209 Function IsRunning (Const mkObjectName: IMoniker):HResult;StdCall;
GetObjectnull210 Function GetObject (Const mkObjectName: IMoniker; Out punkObject:IUnknown):HResult; StdCall;
NoteChangeTimenull211 Function NoteChangeTime(dwRegister :DWord;Const FileTime: TFileTime):HResult;StdCall;
GetTimeOfLastChangenull212 Function GetTimeOfLastChange(Const mkObjectName:IMoniker;Out filetime:TFileTime):HResult; StdCall;
EnumRunningnull213 Function EnumRunning (Out enumMoniker: IEnumMoniker):HResult; StdCall;
214 End;
215
216
217 IBindCtx = Interface (IUnknown)
218 ['{0000000e-0000-0000-C000-000000000046}']
RegisterObjectBoundnull219 Function RegisterObjectBound(Const punk:IUnknown):HResult; stdCall;
RevokeObjectBoundnull220 Function RevokeObjectBound (Const Punk:IUnknown):HResult; stdCall;
ReleaseBoundObjectsnull221 Function ReleaseBoundObjects :HResult; StdCall;
SetBindOptionsnull222 Function SetBindOptions(Const bindOpts:TBind_Opts):HResult; stdCall;
RemoteSetBindOptionsnull223 // Function RemoteSetBindOptions(Const bind_opts: TBind_Opts2):HResult;StdCall;
224 Function GetBindOptions(var BindOpts:TBind_Opts):HResult; stdCall;
RemoteGetBindOptionsnull225 // Function RemoteGetBindOptions(Var bind_opts: TBind_Opts2):HResult;StdCall;
226 Function GetRunningObjectTable(Out rot : IRunningObjectTable):Hresult; StdCall;
RegisterObjectParamnull227 Function RegisterObjectParam(Const pszkey:LPOleStr;const punk:IUnknown):HResult;
GetObjectParamnull228 Function GetObjectParam(Const pszkey:LPOleStr; out punk: IUnknown):HResult; StdCall;
EnumObjectParamnull229 Function EnumObjectParam (out enum:IEnumString):Hresult;StdCall;
RevokeObjectParamnull230 Function RevokeObjectParam(pszKey:LPOleStr):HResult;StdCall;
231 End;
232
233
234 PIMoniker = ^IMoniker;
235 IMoniker = Interface (IPersistStream)
236 ['{0000000f-0000-0000-C000-000000000046}']
BindToObjectnull237 Function BindToObject (const pbc:IBindCtx;const mktoleft:IMoniker; RiidResult:TIID;Out vresult):HResult;StdCall;
RemoteBindToObjectnull238 // Function RemoteBindToObject (const pbc:IBindCtx;const mktoleft:IMoniker;RiidResult:TIID;Out vresult):HResult;StdCall;
239 Function BindToStorage(Const Pbc:IBindCtx;Const mktoLeft:IMoniker; Riid:TIID;Out vobj):HResult; StdCall;
RemoteBindToStoragenull240 // Function RemoteBindToStorage(Const Pbc:IBindCtx;Const mktoLeft:IMoniker; Riid:TIID;Out vobj):HResult; StdCall;
241 Function Reduce (const pbc:IBindCtx; dwReduceHowFar:DWord; mktoLeft: PIMoniker; Out mkReduced:IMoniker):HResult; StdCall;
ComposeWithnull242 Function ComposeWith(Const MkRight:IMoniker;fOnlyIfNotGeneric:BOOL; OUT mkComposite:IMoniker):HResult; StdCall;
Enumnull243 Function Enum(fForward:Bool;Out enumMoniker:IEnumMoniker):HResult;StdCall;
IsEqualnull244 Function IsEqual(Const mkOtherMoniker:IMoniker):HResult;StdCall;
Hashnull245 Function Hash (Out dwHash:Dword):HResult;StdCall;
IsRunningnull246 Function IsRunning(Const bc:IBindCtx;Const MkToLeft:IMoniker;Const mknewlyRunning:IMoniker):HResult;StdCall;
GetTimeOfLastChangenull247 Function GetTimeOfLastChange(Const bc:IBindCtx;Const mkToLeft:IMoniker; out ft : FileTime):HResult; StdCall;
Inversenull248 Function Inverse(out mk : IMoniker):HResult; StdCall;
CommonPrefixWithnull249 Function CommonPrefixWith (Const mkOther:IMoniker):HResult; StdCall;
RelativePathTonull250 Function RelativePathTo(Const mkother:IMoniker; Out mkRelPath : IMoniker):HResult;StdCall;
GetDisplayNamenull251 Function GetDisplayName(Const bc:IMoniker;const mktoleft:IMoniker;Out szDisplayName: pOleStr):HResult; StdCall;
ParseDisplayNamenull252 Function ParseDisplayName(Const bc:IBindCtx;Const mkToLeft:IMoniker;szDisplayName:POleStr;out cheaten:ULong;out mkOut:IMoniker):HResult; StdCall;
IsSystemMonitornull253 Function IsSystemMonitor(Out dwMkSys:DWord):HResult;StdCall;
254 End;
255
256
257 IAdviseSink = Interface (IUnknown)
258 ['{0000010f-0000-0000-C000-000000000046}']
259 {$ifdef midl500} ['{00000150-0000-0000-C000-000000000046}'] {$endif}
260 Procedure OnDataChange (Const pformatetc : Formatetc;const pstgmed : STGMEDIUM); StdCall;
261 Procedure OnViewChange (dwAspect : DWord; lindex : Long); StdCall;
262 Procedure OnRename (Const pmk : IMoniker); StdCall;
263 Procedure OnSave; StdCall;
264 Procedure OnClose; StdCall;
265 End;
266
267
268 //Fake interfaces
269 IDataObject = Interface (IUnknown)
270 ['{0000010e-0000-0000-C000-000000000046}']
GetDatanull271 Function GetData(Const formatetcIn : FORMATETC;Out medium : STGMEDIUM):HRESULT; STDCALL;
GetDataHerenull272 Function GetDataHere(CONST pformatetc : FormatETC; Out medium : STGMEDIUM):HRESULT; STDCALL;
QueryGetDatanull273 Function QueryGetData(const pformatetc : FORMATETC):HRESULT; STDCALL;
GetCanonicalFormatTEtcnull274 Function GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; STDCALl;
SetDatanull275 Function SetData (Const pformatetc : FORMATETC;
276 {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} medium:STGMEDIUM;
277 FRelease : BOOL):HRESULT; StdCall;
EnumFormatEtcnull278 Function EnumFormatEtc(dwDirection : DWord; OUT enumformatetcpara : IENUMFORMATETC):HRESULT; StdCall;
DAdvisenull279 Function DAdvise(const formatetc : FORMATETC;advf :DWORD; CONST AdvSink : IAdviseSink;OUT dwConnection:DWORD):HRESULT;StdCall;
DUnadvisenull280 Function DUnadvise(dwconnection :DWord) :HRESULT;StdCall;
EnumDAvisenull281 Function EnumDAvise(Out enumAdvise : IEnumStatData):HResult;StdCall;
282 End;
283
284 IDropTarget = interface(IUnknown)
285 ['{00000122-0000-0000-C000-000000000046}']
DragEnternull286 function DragEnter(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;StdCall;
DragOvernull287 function DragOver(grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;StdCall;
DragLeavenull288 function DragLeave: HResult;StdCall;
Dropnull289 function Drop(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD):HResult;StdCall;
290 end;
291
292
293 IDropSource = interface(IUnknown)
294 ['{00000121-0000-0000-C000-000000000046}']
QueryContinueDragnull295 function QueryContinueDrag(fEscapePressed: BOOL;
296 grfKeyState: LongWord):HResult;StdCall;
GiveFeedbacknull297 function GiveFeedback(dwEffect: LongWord): HResult;StdCall;
298 end;
299
300
301 IDataAdviseHolder = Interface (IUnknown)
302 ['{00000110-0000-0000-C000-000000000046}']
Advisenull303 Function Advise (CONST pdataObject : IDataObject;CONST fetc:FORMATETC;advf : DWORD;Const pAdvise:IAdviseSink;Out DwConnection:DWord):HResult; StdCall;
Unadvisenull304 Function Unadvise (dwConnection:Dword):HResult; StdCall;
EnumAdvisenull305 Function EnumAdvise(out penumAdvise : IEnumStatData):HResult;StdCall;
SendOnDataChangenull306 Function SendOnDataChange(const pDataObject :IDataObject;DwReserved,advf : DWord):HResult; StdCall;
307 End;
308
309
310
311 // OLE drag'n drop support
312 TFormatEtcArray = array of TFormatEtc;
313 TFormatArray = array of Word;
314
315 // IDataObject.SetData support
316 TInternalStgMedium = packed record
317 Format: TClipFormat;
318 Medium: TStgMedium;
319 end;
320 TInternalStgMediumArray = array of TInternalStgMedium;
321
322 TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc)
323 private
324 FTree: TObject;
325 FFormatEtcArray: TFormatEtcArray;
326 FCurrentIndex: Integer;
327 public
328 constructor Create(Tree: TObject; AFormatEtcArray: TFormatEtcArray);
329 function Clone(out Enum: IEnumFormatEtc): HResult; stdcall;
330 function Next(celt: LongWord; out elt: FormatEtc; out pceltFetched: LongWord): HResult; stdcall;
331 function Reset: HResult; stdcall;
332 function Skip(celt: LongWord): HResult; stdcall;
333 end;
334
335 IDropTargetHelper = interface(IUnknown)
336 [SID_IDropTargetHelper]
337 function DragEnter(hwndTarget: HWND; pDataObject: IDataObject; var ppt: TPoint; dwEffect: LongWord): HRESULT; stdcall;
338 function DragLeave: HRESULT; stdcall;
339 function DragOver(var ppt: TPoint; dwEffect: LongWord): HRESULT; stdcall;
340 function Drop(pDataObject: IDataObject; var ppt: TPoint; dwEffect: LongWord): HRESULT; stdcall;
341 function Show(fShow: Boolean): HRESULT; stdcall;
342 end;
343
344 PSHDragImage = ^TSHDragImage;
345 TSHDragImage = packed record
346 sizeDragImage: TSize;
347 ptOffset: TPoint;
348 hbmpDragImage: HBITMAP;
349 ColorRef: TColorRef;
350 end;
351
352 IDragSourceHelper = interface(IUnknown)
353 [SID_IDragSourceHelper]
354 function InitializeFromBitmap(var SHDragImage: TSHDragImage; pDataObject: IDataObject): HRESULT; stdcall;
355 function InitializeFromWindow(Window: HWND; var ppt: TPoint; pDataObject: IDataObject): HRESULT; stdcall;
356 end;
357
358
359
360 IVTDragManager = interface(IUnknown)
361 ['{C4B25559-14DA-446B-8901-0C879000EB16}']
362 procedure ForceDragLeave; stdcall;
363 function GetDataObject: IDataObject; stdcall;
364 function GetDragSource: TObject; stdcall;
365 function GetDropTargetHelperSupported: Boolean; stdcall;
366 function GetIsDropTarget: Boolean; stdcall;
367
368 property DataObject: IDataObject read GetDataObject;
369 property DragSource: TObject read GetDragSource;
370 property DropTargetHelperSupported: Boolean read GetDropTargetHelperSupported;
371 property IsDropTarget: Boolean read GetIsDropTarget;
372 end;
373
374 // This data object is used in two different places. One is for clipboard operations and the other while dragging.
375 TVTDataObject = class(TInterfacedObject, IDataObject)
376 private
377 //FOwner: TBaseVirtualTree; // The tree which provides clipboard or drag data.
378 FOwner: TObject; // The tree which provides clipboard or drag data.
379 FForClipboard: Boolean; // Determines which data to render with GetData.
380 FFormatEtcArray: TFormatEtcArray;
381 FInternalStgMediumArray: TInternalStgMediumArray; // The available formats in the DataObject
382 FAdviseHolder: IDataAdviseHolder; // Reference to an OLE supplied implementation for advising.
383 protected
384 function CanonicalIUnknown(TestUnknown: IUnknown): IUnknown;
385 function EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean;
386 function FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer;
387 function FindInternalStgMedium(Format: TClipFormat): PStgMedium;
388 function HGlobalClone(HGlobal: THandle): THandle;
389 function RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium; var OLEResult: HResult): Boolean;
390 function StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium;
391 CopyInMedium: Boolean; DataObject: IDataObject): HRESULT;
392
393 property ForClipboard: Boolean read FForClipboard;
394 property FormatEtcArray: TFormatEtcArray read FFormatEtcArray write FFormatEtcArray;
395 property InternalStgMediumArray: TInternalStgMediumArray read FInternalStgMediumArray write FInternalStgMediumArray;
396 property Owner: TObject read FOwner;
397 public
398 constructor Create(AOwner: TObject; ForClipboard: Boolean); virtual;
399 destructor Destroy; override;
400
401 function DAdvise(const FormatEtc: TFormatEtc; advf: DWord; const advSink: IAdviseSink; out dwConnection: DWord):
402 HResult; virtual; stdcall;
403 function DUnadvise(dwConnection: DWord): HResult; virtual; stdcall;
404 Function EnumDAvise(Out enumAdvise : IEnumStatData):HResult;virtual;StdCall;
405 function EnumFormatEtc(Direction: DWord; out EnumFormatEtc: IEnumFormatEtc): HResult; virtual; stdcall;
406 Function GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; virtual; STDCALl;
407 function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall;
408 function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall;
409 function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall;
410 function SetData(const FormatEtc: TFormatEtc;
411 {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium;
412 DoRelease: BOOL): HResult; virtual; stdcall;
413 end;
414
415 // TVTDragManager is a class to manage drag and drop in a Virtual Treeview.
416 TVTDragManager = class(TInterfacedObject, IVTDragManager, IDropSource, IDropTarget)
417 private
418 FOwner, // The tree which is responsible for drag management.
419 FDragSource: TObject; // Reference to the source tree if the source was a VT, might be different than
420 // the owner tree.
421 FIsDropTarget: Boolean; // True if the owner is currently the drop target.
422 FDataObject: IDataObject; // A reference to the data object passed in by DragEnter (only used when the owner
423 // tree is the current drop target).
424 FDropTargetHelper: IDropTargetHelper; // Win2k > Drag image support
425 FFullDragging: BOOL; // True, if full dragging is currently enabled in the system.
426
427 function GetDataObject: IDataObject; stdcall;
428 function GetDragSource: TObject; stdcall;
429 function GetDropTargetHelperSupported: Boolean; stdcall;
430 function GetIsDropTarget: Boolean; stdcall;
431 public
432 constructor Create(AOwner: TObject); virtual;
433 destructor Destroy; override;
434
435 function DragEnter(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint;
436 var Effect: LongWord): HResult; stdcall;
437 function DragLeave: HResult; stdcall;
438 function DragOver(KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult; stdcall;
439 function Drop(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult; stdcall;
440 procedure ForceDragLeave; stdcall;
441 function GiveFeedback(Effect: LongWord): HResult; stdcall;
442 function QueryContinueDrag(EscapePressed: BOOL; KeyState: LongWord): HResult; stdcall;
443 end;
444
445 //Ole helper functions
446
447 function Succeeded(Status : HRESULT) : BOOLEAN;
448
449 function Failed(Status : HRESULT) : BOOLEAN;
450
451 //ActiveX functions that have wrong calling convention in fpc
452
453 function RegisterDragDrop(hwnd:HWND; pDropTarget:IDropTarget):WINOLEAPI;stdcall;
454
455 function RevokeDragDrop(hwnd:HWND):WINOLEAPI;stdcall;
456
457 function DoDragDrop(pDataObj:IDataObject; pDropSource:IDropSource; dwOKEffects:DWORD; pdwEffect:LPDWORD):WINOLEAPI;
458
459 function OleInitialize(pvReserved:LPVOID):WINOLEAPI;stdcall;
460
461 procedure OleUninitialize;stdcall;
462
463 procedure ReleaseStgMedium(_para1:LPSTGMEDIUM);stdcall;
464
465 function OleSetClipboard(pDataObj:IDataObject):WINOLEAPI;stdcall;
466
467 function OleGetClipboard(out ppDataObj:IDataObject):WINOLEAPI;stdcall;
468
469 function OleFlushClipboard:WINOLEAPI;stdcall;
470
471 function OleIsCurrentClipboard(pDataObj:IDataObject):WINOLEAPI;stdcall;
472
473 function CreateStreamOnHGlobal(hGlobal:HGLOBAL; fDeleteOnRelease:BOOL;out stm:IStream):WINOLEAPI;stdcall;
474
475 function CoCreateInstance(const _para1:TCLSID; _para2:IUnknown; _para3:DWORD;const _para4:TIID;out _para5):HRESULT;stdcall;
476
477 //helper functions to isolate windows/OLE specific code
478
479 function RenderOLEData(Tree: TObject; const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;
480 ForClipboard: Boolean): HResult;
481
482 function GetStreamFromMedium(Medium:TStgMedium):TStream;
483
484 procedure UnlockMediumData(Medium:TStgMedium);
485
486 function GetTreeFromDataObject(const DataObject: IDataObject; var Format: TFormatEtc): TObject;
487
488 function AllocateGlobal(Data: Pointer; DataSize:Cardinal): HGLOBAL;
489
490 implementation
491
492 uses
493 opkman_VirtualTrees, Controls {$ifdef DEBUG_VTV}, opkman_vtlogger {$endif};
494
495 type
496 TVirtualTreeAccess = class (TBaseVirtualTree)
497 end;
498
499 function Succeeded(Status : HRESULT) : BOOLEAN;
500 begin
501 Succeeded:=Status and HRESULT($80000000)=0;
502 end;
503
504 function Failed(Status : HRESULT) : BOOLEAN;
505 begin
506 Failed:=Status and HRESULT($80000000)<>0;
507 end;
508
509 function RegisterDragDrop(hwnd: HWND; pDropTarget: IDropTarget): WINOLEAPI;
510 begin
callednull511 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
512 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
513 end;
514
515 function RevokeDragDrop(hwnd: HWND): WINOLEAPI;
516 begin
517 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
518 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
519 end;
520
521 function DoDragDrop(pDataObj: IDataObject; pDropSource: IDropSource;
522 dwOKEffects: DWORD; pdwEffect: LPDWORD): WINOLEAPI;
523 begin
524 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
525 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
526 end;
527
528 function OleInitialize(pvReserved: LPVOID): WINOLEAPI;
529 begin
530 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
531 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
532 end;
533
534 procedure OleUninitialize;
535 begin
536 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
537 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
538 end;
539
540 procedure ReleaseStgMedium(_para1: LPSTGMEDIUM);
541 begin
542 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
543 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
544 end;
545
546 function OleSetClipboard(pDataObj: IDataObject): WINOLEAPI;
547 begin
548 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
549 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
550 end;
551
552 function OleGetClipboard(out ppDataObj: IDataObject): WINOLEAPI;
553 begin
554 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
555 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
556 end;
557
558 function OleFlushClipboard: WINOLEAPI;
559 begin
560 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
561 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
562 end;
563
564 function OleIsCurrentClipboard(pDataObj: IDataObject): WINOLEAPI;
565 begin
566 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
567 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
568 end;
569
570 function CreateStreamOnHGlobal(hGlobal: HGLOBAL; fDeleteOnRelease: BOOL; out
571 stm: IStream): WINOLEAPI;
572 begin
573 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
574 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
575 end;
576
577 function CoCreateInstance(const _para1: TCLSID; _para2: IUnknown;
578 _para3: DWORD; const _para4: TIID; out _para5): HRESULT;
579 begin
580 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
581 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
582 end;
583
584
585 function RenderOLEData(Tree: TObject; const FormatEtcIn: TFormatEtc; out
586 Medium: TStgMedium; ForClipboard: Boolean): HResult;
587 {
588 //--------------- local function --------------------------------------------
589
590 procedure WriteNodes(Stream: TStream);
591
592 var
593 Selection: TNodeArray;
594 I: Integer;
595
596 begin
597 with TVirtualTreeAccess(Tree) do
598 begin
599 if ForClipboard then
600 Selection := GetSortedCutCopySet(True)
601 else
602 Selection := GetSortedSelection(True);
603 for I := 0 to High(Selection) do
604 WriteNode(Stream, Selection[I]);
605 end;
606 end;
607
608 //--------------- end local function ----------------------------------------
609 }
610 var
611 Data: PCardinal;
612 ResPointer: Pointer;
613 ResSize: Integer;
614 OLEStream: IStream;
615 VCLStream: TStream;
616
617 begin
618 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
619 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
620 {
621 VCLStream := nil;
622 try
623 Medium.PunkForRelease := nil;
624 // Return data in one of the supported storage formats, prefer IStream.
625 if FormatEtcIn.tymed and TYMED_ISTREAM <> 0 then
626 begin
627 // Create an IStream on a memory handle (here it is 0 which indicates to implicitely allocated a handle).
628 // Do not use TStreamAdapter as it is not compatible with OLE (when flushing the clipboard OLE wants the HGlobal
629 // back which is not supported by TStreamAdapater).
630 CreateStreamOnHGlobal(0, True, OLEStream);
631
632 VCLStream := TOLEStream.Create(OLEStream);
633 WriteNodes(VCLStream);
634 // Rewind stream.
635 VCLStream.Position := 0;
636 Medium.tymed := TYMED_ISTREAM;
637 IUnknown(Medium.Pstm) := OLEStream;
638 Result := S_OK;
639 end
640 else
641 begin
642 VCLStream := TMemoryStream.Create;
643 WriteNodes(VCLStream);
644 ResPointer := TMemoryStream(VCLStream).Memory;
645 ResSize := VCLStream.Position;
646
647 // Allocate memory to hold the string.
648 if ResSize > 0 then
649 begin
650 Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, ResSize + SizeOf(Cardinal));
651 Data := GlobalLock(Medium.hGlobal);
652 // Store the size of the data too, for easy retrival.
653 Data^ := ResSize;
654 Inc(Data);
655 Move(ResPointer^, Data^, ResSize);
656 GlobalUnlock(Medium.hGlobal);
657 Medium.tymed := TYMED_HGLOBAL;
658
659 Result := S_OK;
660 end
661 else
662 Result := E_FAIL;
663 end;
664 finally
665 // We can free the VCL stream here since it was either a pure memory stream or only a wrapper around
666 // the OLEStream which exists independently.
667 VCLStream.Free;
668 end;
669 }
670 end;
671
672
673 type
674 // needed to handle OLE global memory objects
675 TOLEMemoryStream = class(TCustomMemoryStream)
676 public
677 function Write(const Buffer; Count: Integer): Longint; override;
678 end;
679
680 //----------------------------------------------------------------------------------------------------------------------
681
Writenull682 function TOLEMemoryStream.Write(const Buffer; Count: Integer): Integer;
683
684 begin
685 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
686 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
687 // raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError));
688 end;
689
690
691 function GetStreamFromMedium(Medium: TStgMedium): TStream;
692
693 var
694 Data: Pointer;
695 I: Integer;
696 begin
697 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
698 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
699 {
700 Result := nil;
701 if Medium.tymed = TYMED_ISTREAM then
702 Result := TOLEStream.Create(IUnknown(Medium.Pstm) as IStream)
703 else
704 begin
705 Data := GlobalLock(Medium.hGlobal);
706 if Assigned(Data) then
707 begin
708 // Get the total size of data to retrieve.
709 I := PCardinal(Data)^;
710 Inc(PCardinal(Data));
711 Result := TOLEMemoryStream.Create;
712 TOLEMemoryStream(Result).SetPointer(Data, I);
713 end;
714 end;
715 }
716 end;
717
718 procedure UnlockMediumData(Medium: TStgMedium);
719 begin
720 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
721 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
722 {
723 if Medium.tymed = TYMED_HGLOBAL then
724 GlobalUnlock(Medium.hGlobal);
725 }
726 end;
727
728 function GetTreeFromDataObject(const DataObject: IDataObject;
729 var Format: TFormatEtc): TObject;
730
731 var
732 Medium: TStgMedium;
733 Data: PVTReference;
734
735 begin
736 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
737 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
738 {
739 Result := nil;
740 if Assigned(DataObject) then
741 begin
742 Format.cfFormat := CF_VTREFERENCE;
743 if DataObject.GetData(Format, Medium) = S_OK then
744 begin
745 Data := GlobalLock(Medium.hGlobal);
746 if Assigned(Data) then
747 begin
748 if Data.Process = GetCurrentProcessID then
749 Result := Data.Tree;
750 GlobalUnlock(Medium.hGlobal);
751 end;
752 ReleaseStgMedium(@Medium);
753 end;
754 end;
755 }
756 end;
757
758 function AllocateGlobal(Data: Pointer; DataSize: Cardinal): HGLOBAL;
759 var
760 P:Pointer;
761 begin
762 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
763 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
764 {
765 Result := GlobalAlloc(GHND or GMEM_SHARE, DataSize);
766 P := GlobalLock(Result);
767 Move(Data^, P^, DataSize);
768 GlobalUnlock(Result);
769 }
770 end;
771
772 //----------------------------------------------------------------------------------------------------------------------
773
774 // OLE drag and drop support classes
775 // This is quite heavy stuff (compared with the VCL implementation) but is much better suited to fit the needs
776 // of DD'ing various kinds of virtual data and works also between applications.
777
778 //----------------- TEnumFormatEtc -------------------------------------------------------------------------------------
779
780 constructor TEnumFormatEtc.Create(Tree: TObject; AFormatEtcArray: TFormatEtcArray);
781
782 var
783 I: Integer;
784
785 begin
786 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
787 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
788 {
789 inherited Create;
790
791 FTree := Tree;
792 // Make a local copy of the format data.
793 SetLength(FFormatEtcArray, Length(AFormatEtcArray));
794 for I := 0 to High(AFormatEtcArray) do
795 FFormatEtcArray[I] := AFormatEtcArray[I];
796 }
797 end;
798
799 //----------------------------------------------------------------------------------------------------------------------
800
TEnumFormatEtc.Clonenull801 function TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult;
802
803 var
804 AClone: TEnumFormatEtc;
805
806 begin
807 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
808 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
809 {
810 Result := S_OK;
811 try
812 AClone := TEnumFormatEtc.Create(nil, FFormatEtcArray);
813 AClone.FCurrentIndex := FCurrentIndex;
814 Enum := AClone as IEnumFormatEtc;
815 except
816 Result := E_FAIL;
817 end;
818 }
819 end;
820
821 //----------------------------------------------------------------------------------------------------------------------
822
Nextnull823 function TEnumFormatEtc.Next(celt: LongWord; out elt: FormatEtc; out pceltFetched: LongWord): HResult;
824
825 var
826 CopyCount: LongWord;
827
828 begin
829 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
830 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
831 {
832 Result := S_FALSE;
833 CopyCount := Length(FFormatEtcArray) - FCurrentIndex;
834 if celt < CopyCount then
835 CopyCount := celt;
836 if CopyCount > 0 then
837 begin
838 Move(FFormatEtcArray[FCurrentIndex], elt, CopyCount * SizeOf(TFormatEtc));
839 Inc(FCurrentIndex, CopyCount);
840 Result := S_OK;
841 end;
842 //todo_lcl_check Delphi treats pceltFetched an PInteger. Implemented like in fpc.activex. What heappens with
843 // a C Program call with a NULL in pCeltFetcjed??
844 //Answer: Yes. Is necessary a check here
845 if @pceltFetched <> nil then
846 pceltFetched := CopyCount;
847 }
848 end;
849
850 //----------------------------------------------------------------------------------------------------------------------
851
TEnumFormatEtc.Resetnull852 function TEnumFormatEtc.Reset: HResult;
853
854 begin
855 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
856 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
857 {
858 FCurrentIndex := 0;
859 Result := S_OK;
860 }
861 end;
862
863 //----------------------------------------------------------------------------------------------------------------------
864
Skipnull865 function TEnumFormatEtc.Skip(celt: LongWord): HResult;
866
867 begin
868 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
869 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
870 {
871 if FCurrentIndex + celt < High(FFormatEtcArray) then
872 begin
873 Inc(FCurrentIndex, celt);
874 Result := S_Ok;
875 end
876 else
877 Result := S_FALSE;
878 }
879 end;
880
881
882 //----------------- TVTDataObject --------------------------------------------------------------------------------------
883
884 constructor TVTDataObject.Create(AOwner: TObject; ForClipboard: Boolean);
885
886 begin
887 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
888 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
889 {
890 inherited Create;
891
892 FOwner := AOwner;
893 FForClipboard := ForClipboard;
894 TVirtualTreeAccess(FOwner).GetNativeClipboardFormats(FFormatEtcArray);
895 }
896 end;
897
898 //----------------------------------------------------------------------------------------------------------------------
899
900 destructor TVTDataObject.Destroy;
901
902 var
903 I: Integer;
904 StgMedium: PStgMedium;
905
906 begin
907 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
908 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
909 {
910 // Cancel a pending clipboard operation if this data object was created for the clipboard and
911 // is freed because something else is placed there.
912 if FForClipboard and not (tsClipboardFlushing in TVirtualTreeAccess(FOwner).TreeStates) then
913 TVirtualTreeAccess(FOwner).CancelCutOrCopy;
914
915 // Release any internal clipboard formats
916 for I := 0 to High(FormatEtcArray) do
917 begin
918 StgMedium := FindInternalStgMedium(FormatEtcArray[I].cfFormat);
919 if Assigned(StgMedium) then
920 ReleaseStgMedium(StgMedium);
921 end;
922
923 FormatEtcArray := nil;
924 inherited;
925 }
926 end;
927
928 //----------------------------------------------------------------------------------------------------------------------
929
CanonicalIUnknownnull930 function TVTDataObject.CanonicalIUnknown(TestUnknown: IUnknown): IUnknown;
931
932 // Uses COM object identity: An explicit call to the IUnknown::QueryInterface method, requesting the IUnknown
933 // interface, will always return the same pointer.
934
935 begin
936 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
937 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
938 {
939 if Assigned(TestUnknown) then
940 begin
941 if TestUnknown.QueryInterface(IUnknown, Result) = 0 then
942 Result._Release // Don't actually need it just need the pointer value
943 else
944 Result := TestUnknown
945 end
946 else
947 Result := TestUnknown
948 }
949 end;
950
951 //----------------------------------------------------------------------------------------------------------------------
952
EqualFormatEtcnull953 function TVTDataObject.EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean;
954
955 begin
956 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
957 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
958 {
959 Result := (FormatEtc1.cfFormat = FormatEtc2.cfFormat) and (FormatEtc1.ptd = FormatEtc2.ptd) and
960 (FormatEtc1.dwAspect = FormatEtc2.dwAspect) and (FormatEtc1.lindex = FormatEtc2.lindex) and
961 (FormatEtc1.tymed and FormatEtc2.tymed <> 0);
962
963 }
964 end;
965
966 //----------------------------------------------------------------------------------------------------------------------
967
FindFormatEtcnull968 function TVTDataObject.FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer;
969
970 var
971 I: integer;
972
973 begin
974 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
975 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
976 {
977 Result := -1;
978 for I := 0 to High(FormatEtcArray) do
979 begin
980 if EqualFormatEtc(TestFormatEtc, FormatEtcArray[I]) then
981 begin
982 Result := I;
983 Break;
984 end
985 end;
986 }
987 end;
988
989 //----------------------------------------------------------------------------------------------------------------------
990
FindInternalStgMediumnull991 function TVTDataObject.FindInternalStgMedium(Format: TClipFormat): PStgMedium;
992
993 var
994 I: integer;
995 begin
996 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
997 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
998 {
999 Result := nil;
1000 for I := 0 to High(InternalStgMediumArray) do
1001 begin
1002 if Format = InternalStgMediumArray[I].Format then
1003 begin
1004 Result := @InternalStgMediumArray[I].Medium;
1005 Break;
1006 end
1007 end;
1008 }
1009 end;
1010
1011 //----------------------------------------------------------------------------------------------------------------------
1012
TVTDataObject.HGlobalClonenull1013 function TVTDataObject.HGlobalClone(HGlobal: THandle): THandle;
1014
1015 // Returns a global memory block that is a copy of the passed memory block.
1016
1017 var
1018 Size: Cardinal;
1019 Data,
1020 NewData: PChar;
1021
1022 begin
1023 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1024 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1025 {
1026 Size := GlobalSize(HGlobal);
1027 Result := GlobalAlloc(GPTR, Size);
1028 Data := GlobalLock(hGlobal);
1029 try
1030 NewData := GlobalLock(Result);
1031 try
1032 Move(Data^, NewData^, Size);
1033 finally
1034 GlobalUnLock(Result);
1035 end
1036 finally
1037 GlobalUnLock(hGlobal);
1038 end;
1039 }
1040 end;
1041
1042 //----------------------------------------------------------------------------------------------------------------------
1043
TVTDataObject.RenderInternalOLEDatanull1044 function TVTDataObject.RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium;
1045 var OLEResult: HResult): Boolean;
1046
1047 // Tries to render one of the formats which have been stored via the SetData method.
1048 // Since this data is already there it is just copied or its reference count is increased (depending on storage medium).
1049
1050 var
1051 InternalMedium: PStgMedium;
1052
1053 begin
1054 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1055 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1056 {
1057
1058 Result := True;
1059 InternalMedium := FindInternalStgMedium(FormatEtcIn.cfFormat);
1060 if Assigned(InternalMedium) then
1061 OLEResult := StgMediumIncRef(InternalMedium^, Medium, False, Self as IDataObject)
1062 else
1063 Result := False;
1064 }
1065 end;
1066
1067 //----------------------------------------------------------------------------------------------------------------------
1068
StgMediumIncRefnull1069 function TVTDataObject.StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium;
1070 CopyInMedium: Boolean; DataObject: IDataObject): HRESULT;
1071
1072 // InStgMedium is the data that is requested, OutStgMedium is the data that we are to return either a copy of or
1073 // increase the IDataObject's reference and send ourselves back as the data (unkForRelease). The InStgMedium is usually
1074 // the result of a call to find a particular FormatEtc that has been stored locally through a call to SetData.
1075 // If CopyInMedium is not true we already have a local copy of the data when the SetData function was called (during
1076 // that call the CopyInMedium must be true). Then as the caller asks for the data through GetData we do not have to make
1077 // copy of the data for the caller only to have them destroy it then need us to copy it again if necessary.
1078 // This way we increase the reference count to ourselves and pass the STGMEDIUM structure initially stored in SetData.
1079 // This way when the caller frees the structure it sees the unkForRelease is not nil and calls Release on the object
1080 // instead of destroying the actual data.
1081
1082 var
1083 Len: Integer;
1084
1085 begin
callednull1086 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1087 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1088 {
1089 Result := S_OK;
1090
1091 // Simply copy all fields to start with.
1092 OutStgMedium := InStgMedium;
1093 // The data handled here always results from a call of SetData we got. This ensures only one storage format
1094 // is indicated and hence the case statement below is safe (IDataObject.GetData can optionally use several
1095 // storage formats).
1096 case InStgMedium.tymed of
1097 TYMED_HGLOBAL:
1098 begin
1099 if CopyInMedium then
1100 begin
1101 // Generate a unique copy of the data passed
1102 OutStgMedium.hGlobal := HGlobalClone(InStgMedium.hGlobal);
1103 if OutStgMedium.hGlobal = 0 then
1104 Result := E_OUTOFMEMORY
1105 end
1106 else
1107 // Don't generate a copy just use ourselves and the copy previously saved.
1108 OutStgMedium.PunkForRelease := Pointer(DataObject); // Does not increase RefCount.
1109 end;
1110 TYMED_FILE:
1111 begin
1112 //todo_lcl_check
1113 Len := Length(WideString(InStgMedium.lpszFileName)) + 1; // Don't forget the terminating null character.
1114 OutStgMedium.lpszFileName := CoTaskMemAlloc(2 * Len);
1115 Move(InStgMedium.lpszFileName^, OutStgMedium.lpszFileName^, 2 * Len);
1116 end;
1117 TYMED_ISTREAM:
1118 IUnknown(OutStgMedium.Pstm)._AddRef;
1119 TYMED_ISTORAGE:
1120 IUnknown(OutStgMedium.Pstg)._AddRef;
1121 TYMED_GDI:
1122 if not CopyInMedium then
1123 // Don't generate a copy just use ourselves and the previously saved data.
1124 OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount.
1125 else
1126 Result := DV_E_TYMED; // Don't know how to copy GDI objects right now.
1127 TYMED_MFPICT:
1128 if not CopyInMedium then
1129 // Don't generate a copy just use ourselves and the previously saved data.
1130 OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount.
1131 else
1132 Result := DV_E_TYMED; // Don't know how to copy MetaFile objects right now.
1133 TYMED_ENHMF:
1134 if not CopyInMedium then
1135 // Don't generate a copy just use ourselves and the previously saved data.
1136 OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount.
1137 else
1138 Result := DV_E_TYMED; // Don't know how to copy enhanced metafiles objects right now.
1139 else
1140 Result := DV_E_TYMED;
1141 end;
1142
1143 if (Result = S_OK) and Assigned(OutStgMedium.PunkForRelease) then
1144 IUnknown(OutStgMedium.PunkForRelease)._AddRef;
1145 }
1146 end;
1147
1148 //----------------------------------------------------------------------------------------------------------------------
1149
DAdvisenull1150 function TVTDataObject.DAdvise(const FormatEtc: TFormatEtc; advf: DWord; const advSink: IAdviseSink;
1151 out dwConnection: DWord): HResult;
1152
1153 // Advise sink management is greatly simplified by the IDataAdviseHolder interface.
1154 // We use this interface and forward all concerning calls to it.
1155
1156 begin
callednull1157 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1158 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1159 {
1160 Result := S_OK;
1161 if FAdviseHolder = nil then
1162 Result := CreateDataAdviseHolder(FAdviseHolder);
1163 if Result = S_OK then
1164 Result := FAdviseHolder.Advise(Self as IDataObject, FormatEtc, advf, advSink, dwConnection);
1165 }
1166 end;
1167
1168 //----------------------------------------------------------------------------------------------------------------------
1169
DUnadvisenull1170 function TVTDataObject.DUnadvise(dwConnection: DWord): HResult;
1171
1172 begin
1173 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1174 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1175 {
1176 if FAdviseHolder = nil then
1177 Result := E_NOTIMPL
1178 else
1179 Result := FAdviseHolder.Unadvise(dwConnection);
1180 }
1181 end;
1182
1183 //----------------------------------------------------------------------------------------------------------------------
1184
EnumDAvisenull1185 function TVTDataObject.EnumDAvise(Out enumAdvise : IEnumStatData):HResult;
1186
1187 begin
1188 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1189 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1190 {
1191 if FAdviseHolder = nil then
1192 Result := OLE_E_ADVISENOTSUPPORTED
1193 else
1194 Result := FAdviseHolder.EnumAdvise(enumAdvise);
1195 }
1196 end;
1197
1198 //----------------------------------------------------------------------------------------------------------------------
1199
EnumFormatEtcnull1200 function TVTDataObject.EnumFormatEtc(Direction: DWord; out EnumFormatEtc: IEnumFormatEtc): HResult;
1201
1202 var
1203 NewList: TEnumFormatEtc;
1204
1205 begin
1206 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1207 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1208 {
1209 Result := E_FAIL;
1210 if Direction = DATADIR_GET then
1211 begin
1212 NewList := TEnumFormatEtc.Create(TVirtualTreeAccess(FOwner), FormatEtcArray);
1213 EnumFormatEtc := NewList as IEnumFormatEtc;
1214 Result := S_OK;
1215 end
1216 else
1217 EnumFormatEtc := nil;
1218 if EnumFormatEtc = nil then
1219 Result := OLE_S_USEREG;
1220 }
1221 end;
1222
1223 //----------------------------------------------------------------------------------------------------------------------
1224
1225 Function TVTDataObject.GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult;
1226
1227 begin
1228 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1229 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1230 //Result := DATA_S_SAMEFORMATETC;
1231 end;
1232
1233 //----------------------------------------------------------------------------------------------------------------------
1234
GetDatanull1235 function TVTDataObject.GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult;
1236
1237 // Data is requested by clipboard or drop target. This method dispatchs the call
1238 // depending on the data being requested.
1239
1240 var
1241 I: Integer;
1242 Data: PVTReference;
1243
1244 begin
1245 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1246 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1247 // The tree reference format is always supported and returned from here.
1248 {
1249 if FormatEtcIn.cfFormat = CF_VTREFERENCE then
1250 begin
1251 // Note: this format is not used while flushing the clipboard to avoid a dangling reference
1252 // when the owner tree is destroyed before the clipboard data is replaced with something else.
1253 if tsClipboardFlushing in TVirtualTreeAccess(FOwner).TreeStates then
1254 Result := E_FAIL
1255 else
1256 begin
1257 Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference));
1258 Data := GlobalLock(Medium.hGlobal);
1259 Data.Process := GetCurrentProcessID;
1260 Data.Tree := TBaseVirtualTree(FOwner);
1261 GlobalUnlock(Medium.hGlobal);
1262 Medium.tymed := TYMED_HGLOBAL;
1263 Medium.PunkForRelease := nil;
1264 Result := S_OK;
1265 end;
1266 end
1267 else
1268 begin
1269 try
1270 // See if we accept this type and if not get the correct return value.
1271 Result := QueryGetData(FormatEtcIn);
1272 if Result = S_OK then
1273 begin
1274 for I := 0 to High(FormatEtcArray) do
1275 begin
1276 if EqualFormatEtc(FormatEtcIn, FormatEtcArray[I]) then
1277 begin
1278 if not RenderInternalOLEData(FormatEtcIn, Medium, Result) then
1279 Result := TVirtualTreeAccess(FOwner).RenderOLEData(FormatEtcIn, Medium, FForClipboard);
1280 Break;
1281 end;
1282 end
1283 end
1284 except
1285 FillChar(Medium, SizeOf(Medium), #0);
1286 Result := E_FAIL;
1287 end;
1288 end;
1289 }
1290 end;
1291
1292 //----------------------------------------------------------------------------------------------------------------------
1293
GetDataHerenull1294 function TVTDataObject.GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult;
1295
1296 begin
1297 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1298 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1299 //Result := E_NOTIMPL;
1300 end;
1301
1302 //----------------------------------------------------------------------------------------------------------------------
1303
QueryGetDatanull1304 function TVTDataObject.QueryGetData(const FormatEtc: TFormatEtc): HResult;
1305
1306 var
1307 I: Integer;
1308
1309 begin
1310 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1311 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1312 {
1313 Result := DV_E_CLIPFORMAT;
1314 for I := 0 to High(FFormatEtcArray) do
1315 begin
1316 if FormatEtc.cfFormat = FFormatEtcArray[I].cfFormat then
1317 begin
1318 if (FormatEtc.tymed and FFormatEtcArray[I].tymed) <> 0 then
1319 begin
1320 if FormatEtc.dwAspect = FFormatEtcArray[I].dwAspect then
1321 begin
1322 if FormatEtc.lindex = FFormatEtcArray[I].lindex then
1323 begin
1324 Result := S_OK;
1325 Break;
1326 end
1327 else
1328 Result := DV_E_LINDEX;
1329 end
1330 else
1331 Result := DV_E_DVASPECT;
1332 end
1333 else
1334 Result := DV_E_TYMED;
1335 end;
1336 end
1337 }
1338 end;
1339
1340 //----------------------------------------------------------------------------------------------------------------------
1341
SetDatanull1342 function TVTDataObject.SetData(const FormatEtc: TFormatEtc;
1343 {$IF FPC_FullVersion >= 30200}var{$ELSE}const{$IFEND} Medium: TStgMedium;
1344 DoRelease: BOOL): HResult;
1345
1346 // Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement
1347 // IDropSourceHelper and allows to set a special format for optimized moves during a shell transfer.
1348
1349 var
1350 Index: Integer;
1351 LocalStgMedium: PStgMedium;
1352
1353 begin
1354 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1355 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1356 {
1357 // See if we already have a format of that type available.
1358 Index := FindFormatEtc(FormatEtc, FormatEtcArray);
1359 if Index > - 1 then
1360 begin
1361 // Just use the TFormatEct in the array after releasing the data.
1362 LocalStgMedium := FindInternalStgMedium(FormatEtcArray[Index].cfFormat);
1363 if Assigned(LocalStgMedium) then
1364 begin
1365 ReleaseStgMedium(LocalStgMedium);
1366 FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0);
1367 end;
1368 end
1369 else
1370 begin
1371 // It is a new format so create a new TFormatCollectionItem, copy the
1372 // FormatEtc parameter into the new object and and put it in the list.
1373 SetLength(FFormatEtcArray, Length(FormatEtcArray) + 1);
1374 FormatEtcArray[High(FormatEtcArray)] := FormatEtc;
1375
1376 // Create a new InternalStgMedium and initialize it and associate it with the format.
1377 SetLength(FInternalStgMediumArray, Length(InternalStgMediumArray) + 1);
1378 InternalStgMediumArray[High(InternalStgMediumArray)].Format := FormatEtc.cfFormat;
1379 LocalStgMedium := @InternalStgMediumArray[High(InternalStgMediumArray)].Medium;
1380 FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0);
1381 end;
1382
1383 if DoRelease then
1384 begin
1385 // We are simply being given the data and we take control of it.
1386 LocalStgMedium^ := Medium;
1387 Result := S_OK
1388 end
1389 else
1390 begin
1391 // We need to reference count or copy the data and keep our own references to it.
1392 Result := StgMediumIncRef(Medium, LocalStgMedium^, True, Self as IDataObject);
1393
1394 // Can get a circular reference if the client calls GetData then calls SetData with the same StgMedium.
1395 // Because the unkForRelease for the IDataObject can be marshalled it is necessary to get pointers that
1396 // can be correctly compared. See the IDragSourceHelper article by Raymond Chen at MSDN.
1397 if Assigned(LocalStgMedium.PunkForRelease) then
1398 begin
1399 if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.PunkForRelease)) then
1400 IUnknown(LocalStgMedium.PunkForRelease) := nil; // release the interface
1401 end;
1402 end;
1403
1404 // Tell all registered advice sinks about the data change.
1405 if Assigned(FAdviseHolder) then
1406 FAdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0);
1407 }
1408 end;
1409
1410
1411 //----------------- TVTDragManager -------------------------------------------------------------------------------------
1412
1413 constructor TVTDragManager.Create(AOwner: TObject);
1414
1415 begin
1416 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1417 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1418 {
1419 inherited Create;
1420 FOwner := AOwner;
1421
1422 // Create an instance of the drop target helper interface. This will fail but not harm on systems which do
1423 // not support this interface (everything below Windows 2000);
1424 CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IID_IDropTargetHelper, FDropTargetHelper);
1425 }
1426 end;
1427
1428 //----------------------------------------------------------------------------------------------------------------------
1429
1430 destructor TVTDragManager.Destroy;
1431
1432 begin
1433 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1434 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1435 {
1436 // Set the owner's reference to us to nil otherwise it will access an invalid pointer
1437 // after our desctruction is complete.
1438 TVirtualTreeAccess(FOwner).FreeDragManager;
1439 inherited;
1440 }
1441 end;
1442
1443 //----------------------------------------------------------------------------------------------------------------------
1444
TVTDragManager.GetDataObjectnull1445 function TVTDragManager.GetDataObject: IDataObject;
1446
1447 begin
1448 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1449 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1450 {
1451 // When the owner tree starts a drag operation then it gets a data object here to pass it to the OLE subsystem.
1452 // In this case there is no local reference to a data object and one is created (but not stored).
1453 // If there is a local reference then the owner tree is currently the drop target and the stored interface is
1454 // that of the drag initiator.
1455 if Assigned(FDataObject) then
1456 Result := FDataObject
1457 else
1458 begin
1459 Result := TVirtualTreeAccess(FOwner).DoCreateDataObject;
1460 if Result = nil then
1461 Result := TVTDataObject.Create(FOwner, False) as IDataObject;
1462 end;
1463 }
1464 end;
1465
1466 //----------------------------------------------------------------------------------------------------------------------
1467
TVTDragManager.GetDragSourcenull1468 function TVTDragManager.GetDragSource: TObject;
1469
1470 begin
1471 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1472 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1473 //Result := FDragSource;
1474 end;
1475
1476 //----------------------------------------------------------------------------------------------------------------------
1477
TVTDragManager.GetDropTargetHelperSupportednull1478 function TVTDragManager.GetDropTargetHelperSupported: Boolean;
1479
1480 begin
1481 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1482 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1483 //Result := Assigned(FDropTargetHelper);
1484 end;
1485
1486 //----------------------------------------------------------------------------------------------------------------------
1487
GetIsDropTargetnull1488 function TVTDragManager.GetIsDropTarget: Boolean;
1489
1490 begin
1491 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1492 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1493 //Result := FIsDropTarget;
1494 end;
1495
1496 //----------------------------------------------------------------------------------------------------------------------
1497
DragEnternull1498 function TVTDragManager.DragEnter(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint;
1499 var Effect: LongWord): HResult;
1500
1501 begin
1502 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1503 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1504 {
1505 FDataObject := DataObject;
1506 FIsDropTarget := True;
1507
1508 SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @FFullDragging, 0);
1509 // If full dragging of window contents is disabled in the system then our tree windows will be locked
1510 // and cannot be updated during a drag operation. With the following call painting is again enabled.
1511 if not FFullDragging then
1512 LockWindowUpdate(0);
1513 if Assigned(FDropTargetHelper) and FFullDragging then
1514 FDropTargetHelper.DragEnter(TBaseVirtualTree(FOwner).Handle, DataObject, Pt, Effect);
1515
1516 FDragSource := TVirtualTreeAccess(FOwner).GetTreeFromDataObject(DataObject);
1517 Result := TVirtualTreeAccess(FOwner).DragEnter(KeyState, Pt, Effect);
1518 }
1519 end;
1520
1521 //----------------------------------------------------------------------------------------------------------------------
1522
DragLeavenull1523 function TVTDragManager.DragLeave: HResult;
1524
1525 begin
1526 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1527 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1528 {
1529 if Assigned(FDropTargetHelper) and FFullDragging then
1530 FDropTargetHelper.DragLeave;
1531
1532 TVirtualTreeAccess(FOwner).DragLeave;
1533 FIsDropTarget := False;
1534 FDragSource := nil;
1535 FDataObject := nil;
1536 Result := NOERROR;
1537 }
1538 end;
1539
1540 //----------------------------------------------------------------------------------------------------------------------
1541
DragOvernull1542 function TVTDragManager.DragOver(KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult;
1543
1544 begin
1545 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1546 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1547 {
1548 if Assigned(FDropTargetHelper) and FFullDragging then
1549 FDropTargetHelper.DragOver(Pt, Effect);
1550
1551 Result := TVirtualTreeAccess(FOwner).DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect);
1552 }
1553 end;
1554
1555 //----------------------------------------------------------------------------------------------------------------------
1556
TVTDragManager.Dropnull1557 function TVTDragManager.Drop(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint;
1558 var Effect: LongWord): HResult;
1559
1560 begin
1561 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1562 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1563 {
1564 if Assigned(FDropTargetHelper) and FFullDragging then
1565 FDropTargetHelper.Drop(DataObject, Pt, Effect);
1566
1567 Result := TVirtualTreeAccess(FOwner).DragDrop(DataObject, KeyState, Pt, Effect);
1568 FIsDropTarget := False;
1569 FDataObject := nil;
1570 }
1571 end;
1572
1573 //----------------------------------------------------------------------------------------------------------------------
1574
1575 procedure TVTDragManager.ForceDragLeave;
1576
1577 // Some drop targets, e.g. Internet Explorer leave a drag image on screen instead removing it when they receive
1578 // a drop action. This method calls the drop target helper's DragLeave method to ensure it removes the drag image from
1579 // screen. Unfortunately, sometimes not even this does help (e.g. when dragging text from VT to a text field in IE).
1580
1581 begin
1582 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1583 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1584 {
1585 if Assigned(FDropTargetHelper) and FFullDragging then
1586 FDropTargetHelper.DragLeave;
1587 }
1588 end;
1589
1590 //----------------------------------------------------------------------------------------------------------------------
1591
GiveFeedbacknull1592 function TVTDragManager.GiveFeedback(Effect: LongWord): HResult;
1593
1594 begin
1595 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1596 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1597 //Result := DRAGDROP_S_USEDEFAULTCURSORS;
1598 end;
1599
1600 //----------------------------------------------------------------------------------------------------------------------
1601
QueryContinueDragnull1602 function TVTDragManager.QueryContinueDrag(EscapePressed: BOOL; KeyState: LongWord): HResult;
1603
1604 var
1605 RButton,
1606 LButton: Boolean;
1607
1608 begin
1609 {$ifdef DEBUG_VTV}Logger.SendError([lcOle],'Ole function called in Linux');{$endif}
1610 {$ifdef DEBUG_VTV}Logger.SendCallStack([lcOle],'Stack');{$endif}
1611 {
1612 LButton := (KeyState and MK_LBUTTON) <> 0;
1613 RButton := (KeyState and MK_RBUTTON) <> 0;
1614
1615 // Drag'n drop canceled by pressing both mouse buttons or Esc?
1616 if (LButton and RButton) or EscapePressed then
1617 Result := DRAGDROP_S_CANCEL
1618 else
1619 // Drag'n drop finished?
1620 if not (LButton or RButton) then
1621 Result := DRAGDROP_S_DROP
1622 else
1623 Result := S_OK;
1624 }
1625 end;
1626
1627
1628 end.
1629
1630