diff --git a/components/virtualtreeview-unstable/VirtualTrees.pas b/components/virtualtreeview-unstable/VirtualTrees.pas index 0fd855b64..599b3ba55 100644 --- a/components/virtualtreeview-unstable/VirtualTrees.pas +++ b/components/virtualtreeview-unstable/VirtualTrees.pas @@ -4875,8 +4875,15 @@ var I, Width, Height: Integer; begin + //todo implement under gtk + {$ifdef Windows} Width := GetSystemMetrics(SM_CXMENUCHECK) + 3; Height := GetSystemMetrics(SM_CYMENUCHECK) + 3; + {$else} + Width:=16; + Height:=16; + {$endif} + IL := TImageList.CreateSize(Width, Height); //with IL do // Handle := ImageList_Create(Width, Height, Flags, 0, AllocBy); @@ -5524,10 +5531,15 @@ var begin if FMiscOptions <> Value then begin + ToBeSet := Value - FMiscOptions; ToBeCleared := FMiscOptions - Value; FMiscOptions := Value; - + {$ifndef Windows} + Exclude(FMiscOptions,toAcceptOLEDrop); + Exclude(ToBeCleared,toAcceptOLEDrop); + Exclude(ToBeSet,toAcceptOLEDrop); + {$endif} with FOwner do if not (csLoading in ComponentState) and HandleAllocated then begin @@ -23691,9 +23703,6 @@ const // Region identifiers for GetRandomRgn APIRGN = 3; SYSRGN = 4; -//todo_lcl -function GetRandomRgn(DC: HDC; Rgn: HRGN; iNum: Integer): Integer; stdcall; external 'GDI32.DLL'; - procedure TBaseVirtualTree.UpdateWindowAndDragImage(const Tree: TBaseVirtualTree; TreeRect: TRect; UpdateNCArea, ReshowDragImage: Boolean); diff --git a/components/virtualtreeview-unstable/units/gtk/virtualdragmanager.pas b/components/virtualtreeview-unstable/units/gtk/virtualdragmanager.pas new file mode 100644 index 000000000..91bb14173 --- /dev/null +++ b/components/virtualtreeview-unstable/units/gtk/virtualdragmanager.pas @@ -0,0 +1,1623 @@ +unit virtualdragmanager; +{fake unit just to compile - not used under non windows} + +{$mode delphi} + +interface + +uses + Classes, SysUtils, Types; + +const + // Drag image helpers for Windows 2000 and up. + IID_IDropTargetHelper: TGUID = (D1: $4657278B; D2: $411B; D3: $11D2; D4: ($83, $9A, $00, $C0, $4F, $D9, $18, $D0)); + IID_IDragSourceHelper: TGUID = (D1: $DE5BF786; D2: $477A; D3: $11D2; D4: ($83, $9D, $00, $C0, $4F, $D9, $18, $D0)); + IID_IDropTarget: TGUID = (D1: $00000122; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46)); + CLSID_DragDropHelper: TGUID = (D1: $4657278A; D2: $411B; D3: $11D2; D4: ($83, $9A, $00, $C0, $4F, $D9, $18, $D0)); + + SID_IDropTargetHelper = '{4657278B-411B-11D2-839A-00C04FD918D0}'; + SID_IDragSourceHelper = '{DE5BF786-477A-11D2-839D-00C04FD918D0}'; + SID_IDropTarget = '{00000122-0000-0000-C000-000000000046}'; + + //Bridge to ActiveX constants + + TYMED_HGLOBAL = 1; + TYMED_ISTREAM = 4; + DVASPECT_CONTENT = 1; + CLSCTX_INPROC_SERVER = $0010; + DROPEFFECT_COPY = 1; + DROPEFFECT_LINK = 4; + DROPEFFECT_MOVE = 2; + DROPEFFECT_NONE = 0; + DROPEFFECT_SCROLL = dword($80000000); + DATADIR_GET = 1; + +type + //types from win unit + Long = LongInt; + WinBool= LongBool; + Bool= WinBool; + ULONG = cardinal; + LONGLONG = int64; + LPDWORD = ^DWORD; + LPVOID = pointer; + + TCOLORREF = cardinal; + + TIID = TGUID; + + LARGE_INTEGER = record + case byte of + 0: (LowPart : DWORD; + HighPart : LONG); + 1: (QuadPart : LONGLONG); + end; + PLARGE_INTEGER = ^LARGE_INTEGER; + _LARGE_INTEGER = LARGE_INTEGER; + + TLargeInteger = Int64; + PLargeInteger = ^TLargeInteger; + + ULARGE_INTEGER = record + case byte of + 0: (LowPart : DWORD; + HighPart : DWORD); + 1: (QuadPart : LONGLONG); + end; + PULARGE_INTEGER = ^ULARGE_INTEGER; + _ULARGE_INTEGER = ULARGE_INTEGER; + + + HANDLE = System.THandle; + HWND = HANDLE; + //HRESULT = System.HResult; + + HBITMAP = HANDLE; + HENHMETAFILE = HANDLE; + + //activex types + + + IMoniker = Interface; + + WINOLEAPI = HResult; + TLCID = DWORD; + + OleChar = WChar; + LPOLESTR = ^OLECHAR; + HMetaFilePict = Pointer; + + + tagBIND_OPTS = Record + cvStruct, // sizeof(BIND_OPTS) + grfFlags, + grfMode, + dwTickCountDeadline : DWord; + End; + TBind_Opts = tagBIND_OPTS; + TCLIPFORMAT = Word; + + tagDVTARGETDEVICE = Record + tdSize : DWord; + tdDriverNameOffset, + tdDeviceNameOffset, + tdPortNameOffset, + tdExtDevmodeOffset : Word; + Data : Record End; + End; + DVTARGETDEVICE = TagDVTARGETDEVICE; + PDVTARGETDEVICE = ^tagDVTARGETDEVICE; + + + + tagFORMATETC = Record + CfFormat : Word {TCLIPFORMAT}; + Ptd : PDVTARGETDEVICE; + dwAspect : DWORD; + lindex : Long; + tymed : DWORD; + End; + FORMATETC = TagFORMATETC; + TFORMATETC = FORMATETC; + LPFORMATETC = ^FORMATETC; + PFormatEtc = LPFORMATETC; + + tagSTATDATA = Record + // field used by: + FORMATETC : Tformatetc; // EnumAdvise, EnumData (cache), EnumFormats + advf : DWord; // EnumAdvise, EnumData (cache) + padvSink : Pointer {IAdviseSink}; // EnumAdvise + dwConnection: DWord; // EnumAdvise + End; + STATDATA = TagStatData; + + + TagSTGMEDIUM = Record + Tymed : DWord; + Case Integer Of + 0 : (HBITMAP : hBitmap; PUnkForRelease : Pointer {IUnknown}); + 1 : (HMETAFILEPICT : hMetaFilePict ); + 2 : (HENHMETAFILE : hEnhMetaFile ); + 3 : (HGLOBAL : hGlobal ); + 4 : (lpszFileName : LPOLESTR ); + 5 : (pstm : Pointer{IStream} ); + 6 : (pstg : Pointer{IStorage} ); + End; + USTGMEDIUM = TagSTGMEDIUM; + STGMEDIUM = USTGMEDIUM; + TStgMedium = TagSTGMEDIUM; + PStgMedium = ^TStgMedium; + LPSTGMEDIUM = ^STGMEDIUM; + + IEnumString = Interface (IUnknown) + ['{00000101-0000-0000-C000-000000000046}'] + Function Next(Celt:ULong;Out xcelt;Out Celtfetched:ULong):HResult; StdCall; +// Function RemoteNext(Celt:ULong; Out celt;Out Celtfetched:ULong):HResult; StdCall; + Function Skip (Celt:ULong):Hresult;StdCall; + Function Reset:HResult;StdCall; + Function Clone(Out penum:IEnumString):HResult;StdCall; + End; + + + IEnumMoniker = Interface (IUnknown) + ['{00000102-0000-0000-C000-000000000046}'] + Function Next(celt:ULong; out Elt;out celftfetched: ULong):HResult; StdCall; +// Function RemoteNext(Celt:ULong; Out rgelt;out celtfetched :ULong):Hresult; StdCall; + Function Skip(celt:Ulong):HResult; StdCall; + Function Reset:HResult; StdCall; + Function Close(out penum:IEnumMoniker):HResult;StdCall; + End; + + IEnumSTATDATA = Interface (IUnknown) + ['{00000105-0000-0000-C000-000000000046}'] + Function Next(Celt:ULong;Out Rgelt:statdata;Out pceltFetched:ULong):HResult; StdCall; +// Function RemoteNext(Celt:ULong;Out Rgelt:statdata;Out pceltFetched:ULong):HResult; StdCall; + Function Skip(Celt:ULong):HResult;StdCall; + Function Reset:HResult;StdCall; + Function Clone(out penum:IEnumstatdata):HResult;StdCall; + End; + + IEnumFORMATETC = Interface (IUnknown) + ['{00000103-0000-0000-C000-000000000046}'] + Function Next(Celt:ULong;Out Rgelt:FormatEtc;Out pceltFetched:ULong):HResult; StdCall; +// Function RemoteNext(Celt:ULong;Out Rgelt:FormatEtc;Out pceltFetched:ULong):HResult; StdCall; + Function Skip(Celt:ULong):HResult;StdCall; + Function Reset:HResult;StdCall; + Function Clone(out penum:IEnumFORMATETC):HResult;StdCall; + End; + + + + IPersist = Interface (IUnknown) + ['{0000010c-0000-0000-C000-000000000046}'] + Function GetClassId(clsid:TClsId):HResult; StdCall; + End; + + IPersistStream = Interface(IPersist) + ['{00000109-0000-0000-C000-000000000046}'] + Function IsDirty:HResult; StdCall; + Function Load(Const stm: IStream):HResult; StdCall; + Function Save(Const stm: IStream;fClearDirty:Bool):HResult;StdCall; + Function GetSizeMax(Out cbSize:ULarge_Integer):HResult; StdCall; + End; + + + IRunningObjectTable = Interface (IUnknown) + ['{00000010-0000-0000-C000-000000000046}'] + Function Register (grfFlags :DWord;const unkobject:IUnknown;Const mkObjectName:IMoniker;Out dwregister:DWord):HResult;StdCall; + Function Revoke (dwRegister:DWord):HResult; StdCall; + Function IsRunning (Const mkObjectName: IMoniker):HResult;StdCall; + Function GetObject (Const mkObjectName: IMoniker; Out punkObject:IUnknown):HResult; StdCall; + Function NoteChangeTime(dwRegister :DWord;Const FileTime: TFileTime):HResult;StdCall; + Function GetTimeOfLastChange(Const mkObjectName:IMoniker;Out filetime:TFileTime):HResult; StdCall; + Function EnumRunning (Out enumMoniker: IEnumMoniker):HResult; StdCall; + End; + + + IBindCtx = Interface (IUnknown) + ['{0000000e-0000-0000-C000-000000000046}'] + Function RegisterObjectBound(Const punk:IUnknown):HResult; stdCall; + Function RevokeObjectBound (Const Punk:IUnknown):HResult; stdCall; + Function ReleaseBoundObjects :HResult; StdCall; + Function SetBindOptions(Const bindOpts:TBind_Opts):HResult; stdCall; +// Function RemoteSetBindOptions(Const bind_opts: TBind_Opts2):HResult;StdCall; + Function GetBindOptions(var BindOpts:TBind_Opts):HResult; stdCall; +// Function RemoteGetBindOptions(Var bind_opts: TBind_Opts2):HResult;StdCall; + Function GetRunningObjectTable(Out rot : IRunningObjectTable):Hresult; StdCall; + Function RegisterObjectParam(Const pszkey:LPOleStr;const punk:IUnknown):HResult; + Function GetObjectParam(Const pszkey:LPOleStr; out punk: IUnknown):HResult; StdCall; + Function EnumObjectParam (out enum:IEnumString):Hresult;StdCall; + Function RevokeObjectParam(pszKey:LPOleStr):HResult;StdCall; + End; + + + PIMoniker = ^IMoniker; + IMoniker = Interface (IPersistStream) + ['{0000000f-0000-0000-C000-000000000046}'] + Function BindToObject (const pbc:IBindCtx;const mktoleft:IMoniker; RiidResult:TIID;Out vresult):HResult;StdCall; +// Function RemoteBindToObject (const pbc:IBindCtx;const mktoleft:IMoniker;RiidResult:TIID;Out vresult):HResult;StdCall; + Function BindToStorage(Const Pbc:IBindCtx;Const mktoLeft:IMoniker; Riid:TIID;Out vobj):HResult; StdCall; +// Function RemoteBindToStorage(Const Pbc:IBindCtx;Const mktoLeft:IMoniker; Riid:TIID;Out vobj):HResult; StdCall; + Function Reduce (const pbc:IBindCtx; dwReduceHowFar:DWord; mktoLeft: PIMoniker; Out mkReduced:IMoniker):HResult; StdCall; + Function ComposeWith(Const MkRight:IMoniker;fOnlyIfNotGeneric:BOOL; OUT mkComposite:IMoniker):HResult; StdCall; + Function Enum(fForward:Bool;Out enumMoniker:IEnumMoniker):HResult;StdCall; + Function IsEqual(Const mkOtherMoniker:IMoniker):HResult;StdCall; + Function Hash (Out dwHash:Dword):HResult;StdCall; + Function IsRunning(Const bc:IBindCtx;Const MkToLeft:IMoniker;Const mknewlyRunning:IMoniker):HResult;StdCall; + Function GetTimeOfLastChange(Const bc:IBindCtx;Const mkToLeft:IMoniker; out ft : FileTime):HResult; StdCall; + Function Inverse(out mk : IMoniker):HResult; StdCall; + Function CommonPrefixWith (Const mkOther:IMoniker):HResult; StdCall; + Function RelativePathTo(Const mkother:IMoniker; Out mkRelPath : IMoniker):HResult;StdCall; + Function GetDisplayName(Const bc:IMoniker;const mktoleft:IMoniker;Out szDisplayName: pOleStr):HResult; StdCall; + Function ParseDisplayName(Const bc:IBindCtx;Const mkToLeft:IMoniker;szDisplayName:POleStr;out cheaten:ULong;out mkOut:IMoniker):HResult; StdCall; + Function IsSystemMonitor(Out dwMkSys:DWord):HResult;StdCall; + End; + + + IAdviseSink = Interface (IUnknown) + ['{0000010f-0000-0000-C000-000000000046}'] + {$ifdef midl500} ['{00000150-0000-0000-C000-000000000046}'] {$endif} + Procedure OnDataChange (Const pformatetc : Formatetc;const pstgmed : STGMEDIUM); StdCall; + Procedure OnViewChange (dwAspect : DWord; lindex : Long); StdCall; + Procedure OnRename (Const pmk : IMoniker); StdCall; + Procedure OnSave; StdCall; + Procedure OnClose; StdCall; + End; + + + //Fake interfaces + IDataObject = Interface (IUnknown) + ['{0000010e-0000-0000-C000-000000000046}'] + Function GetData(Const formatetcIn : FORMATETC;Out medium : STGMEDIUM):HRESULT; STDCALL; + Function GetDataHere(CONST pformatetc : FormatETC; Out medium : STGMEDIUM):HRESULT; STDCALL; + Function QueryGetData(const pformatetc : FORMATETC):HRESULT; STDCALL; + Function GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; STDCALl; + Function SetData (Const pformatetc : FORMATETC;const medium:STGMEDIUM;FRelease : BOOL):HRESULT; StdCall; + Function EnumFormatEtc(dwDirection : DWord; OUT enumformatetcpara : IENUMFORMATETC):HRESULT; StdCall; + Function DAdvise(const formatetc : FORMATETC;advf :DWORD; CONST AdvSink : IAdviseSink;OUT dwConnection:DWORD):HRESULT;StdCall; + Function DUnadvise(dwconnection :DWord) :HRESULT;StdCall; + Function EnumDAvise(Out enumAdvise : IEnumStatData):HResult;StdCall; + End; + + IDropTarget = interface(IUnknown) + ['{00000122-0000-0000-C000-000000000046}'] + 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; + end; + + + IDropSource = interface(IUnknown) + ['{00000121-0000-0000-C000-000000000046}'] + function QueryContinueDrag(fEscapePressed: BOOL; + grfKeyState: Longint):HResult;StdCall; + function GiveFeedback(dwEffect: Longint): HResult;StdCall; + end; + + + IDataAdviseHolder = Interface (IUnknown) + ['{00000110-0000-0000-C000-000000000046}'] + Function Advise (CONST pdataObject : IDataObject;CONST fetc:FORMATETC;advf : DWORD;Const pAdvise:IAdviseSink;Out DwConnection:DWord):HResult; StdCall; + Function Unadvise (dwConnection:Dword):HResult; StdCall; + Function EnumAdvise(out penumAdvise : IEnumStatData):HResult;StdCall; + Function SendOnDataChange(const pDataObject :IDataObject;DwReserved,advf : DWord):HResult; StdCall; + End; + + + + // OLE drag'n drop support + TFormatEtcArray = array of TFormatEtc; + TFormatArray = array of Word; + + // IDataObject.SetData support + TInternalStgMedium = packed record + Format: TClipFormat; + Medium: TStgMedium; + end; + TInternalStgMediumArray = array of TInternalStgMedium; + + TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc) + private + FTree: TObject; + FFormatEtcArray: TFormatEtcArray; + FCurrentIndex: Integer; + public + constructor Create(Tree: TObject; AFormatEtcArray: TFormatEtcArray); + function Clone(out Enum: IEnumFormatEtc): HResult; stdcall; + function Next(celt: LongWord; out elt: FormatEtc; out pceltFetched: LongWord): HResult; stdcall; + function Reset: HResult; stdcall; + function Skip(celt: LongWord): HResult; stdcall; + end; + + IDropTargetHelper = interface(IUnknown) + [SID_IDropTargetHelper] + function DragEnter(hwndTarget: HWND; pDataObject: IDataObject; var ppt: TPoint; dwEffect: Integer): HRESULT; stdcall; + function DragLeave: HRESULT; stdcall; + function DragOver(var ppt: TPoint; dwEffect: Integer): HRESULT; stdcall; + function Drop(pDataObject: IDataObject; var ppt: TPoint; dwEffect: Integer): HRESULT; stdcall; + function Show(fShow: Boolean): HRESULT; stdcall; + end; + + PSHDragImage = ^TSHDragImage; + TSHDragImage = packed record + sizeDragImage: TSize; + ptOffset: TPoint; + hbmpDragImage: HBITMAP; + ColorRef: TColorRef; + end; + + IDragSourceHelper = interface(IUnknown) + [SID_IDragSourceHelper] + function InitializeFromBitmap(var SHDragImage: TSHDragImage; pDataObject: IDataObject): HRESULT; stdcall; + function InitializeFromWindow(Window: HWND; var ppt: TPoint; pDataObject: IDataObject): HRESULT; stdcall; + end; + + + + IVTDragManager = interface(IUnknown) + ['{C4B25559-14DA-446B-8901-0C879000EB16}'] + procedure ForceDragLeave; stdcall; + function GetDataObject: IDataObject; stdcall; + function GetDragSource: TObject; stdcall; + function GetDropTargetHelperSupported: Boolean; stdcall; + function GetIsDropTarget: Boolean; stdcall; + + property DataObject: IDataObject read GetDataObject; + property DragSource: TObject read GetDragSource; + property DropTargetHelperSupported: Boolean read GetDropTargetHelperSupported; + property IsDropTarget: Boolean read GetIsDropTarget; + end; + + // This data object is used in two different places. One is for clipboard operations and the other while dragging. + TVTDataObject = class(TInterfacedObject, IDataObject) + private + //FOwner: TBaseVirtualTree; // The tree which provides clipboard or drag data. + FOwner: TObject; // The tree which provides clipboard or drag data. + FForClipboard: Boolean; // Determines which data to render with GetData. + FFormatEtcArray: TFormatEtcArray; + FInternalStgMediumArray: TInternalStgMediumArray; // The available formats in the DataObject + FAdviseHolder: IDataAdviseHolder; // Reference to an OLE supplied implementation for advising. + protected + function CanonicalIUnknown(TestUnknown: IUnknown): IUnknown; + function EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean; + function FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer; + function FindInternalStgMedium(Format: TClipFormat): PStgMedium; + function HGlobalClone(HGlobal: THandle): THandle; + function RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium; var OLEResult: HResult): Boolean; + function StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium; + CopyInMedium: Boolean; DataObject: IDataObject): HRESULT; + + property ForClipboard: Boolean read FForClipboard; + property FormatEtcArray: TFormatEtcArray read FFormatEtcArray write FFormatEtcArray; + property InternalStgMediumArray: TInternalStgMediumArray read FInternalStgMediumArray write FInternalStgMediumArray; + property Owner: TObject read FOwner; + public + constructor Create(AOwner: TObject; ForClipboard: Boolean); virtual; + destructor Destroy; override; + + function DAdvise(const FormatEtc: TFormatEtc; advf: DWord; const advSink: IAdviseSink; out dwConnection: DWord): + HResult; virtual; stdcall; + function DUnadvise(dwConnection: DWord): HResult; virtual; stdcall; + Function EnumDAvise(Out enumAdvise : IEnumStatData):HResult;virtual;StdCall; + function EnumFormatEtc(Direction: DWord; out EnumFormatEtc: IEnumFormatEtc): HResult; virtual; stdcall; + Function GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; virtual; STDCALl; + function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; + function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; + function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall; + function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall; + end; + + // TVTDragManager is a class to manage drag and drop in a Virtual Treeview. + TVTDragManager = class(TInterfacedObject, IVTDragManager, IDropSource, IDropTarget) + private + FOwner, // The tree which is responsible for drag management. + FDragSource: TObject; // Reference to the source tree if the source was a VT, might be different than + // the owner tree. + FIsDropTarget: Boolean; // True if the owner is currently the drop target. + FDataObject: IDataObject; // A reference to the data object passed in by DragEnter (only used when the owner + // tree is the current drop target). + FDropTargetHelper: IDropTargetHelper; // Win2k > Drag image support + FFullDragging: BOOL; // True, if full dragging is currently enabled in the system. + + function GetDataObject: IDataObject; stdcall; + function GetDragSource: TObject; stdcall; + function GetDropTargetHelperSupported: Boolean; stdcall; + function GetIsDropTarget: Boolean; stdcall; + public + constructor Create(AOwner: TObject); virtual; + destructor Destroy; override; + + function DragEnter(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint; + var Effect: LongWord): HResult; stdcall; + function DragLeave: HResult; stdcall; + function DragOver(KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult; stdcall; + function Drop(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult; stdcall; + procedure ForceDragLeave; stdcall; + function GiveFeedback(Effect: Integer): HResult; stdcall; + function QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult; stdcall; + end; + + //Ole helper functions + + function Succeeded(Status : HRESULT) : BOOLEAN; + + function Failed(Status : HRESULT) : BOOLEAN; + + //ActiveX functions that have wrong calling convention in fpc + + function RegisterDragDrop(hwnd:HWND; pDropTarget:IDropTarget):WINOLEAPI;stdcall; + + function RevokeDragDrop(hwnd:HWND):WINOLEAPI;stdcall; + + function DoDragDrop(pDataObj:IDataObject; pDropSource:IDropSource; dwOKEffects:DWORD; pdwEffect:LPDWORD):WINOLEAPI; + + function OleInitialize(pvReserved:LPVOID):WINOLEAPI;stdcall; + + procedure OleUninitialize;stdcall; + + procedure ReleaseStgMedium(_para1:LPSTGMEDIUM);stdcall; + + function OleSetClipboard(pDataObj:IDataObject):WINOLEAPI;stdcall; + + function OleGetClipboard(out ppDataObj:IDataObject):WINOLEAPI;stdcall; + + function OleFlushClipboard:WINOLEAPI;stdcall; + + function OleIsCurrentClipboard(pDataObj:IDataObject):WINOLEAPI;stdcall; + + function CreateStreamOnHGlobal(hGlobal:HGLOBAL; fDeleteOnRelease:BOOL;out stm:IStream):WINOLEAPI;stdcall; + + function CoCreateInstance(const _para1:TCLSID; _para2:IUnknown; _para3:DWORD;const _para4:TIID;out _para5):HRESULT;stdcall; + + //helper functions to isolate windows/OLE specific code + + function RenderOLEData(Tree: TObject; const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; + ForClipboard: Boolean): HResult; + + function GetStreamFromMedium(Medium:TStgMedium):TStream; + + procedure UnlockMediumData(Medium:TStgMedium); + + function GetTreeFromDataObject(const DataObject: IDataObject; var Format: TFormatEtc): TObject; + + function AllocateGlobal(Data: Pointer; DataSize:Cardinal): HGLOBAL; + +implementation + +uses + VirtualTrees, Controls, vtlogger; + +type + TVirtualTreeAccess = class (TBaseVirtualTree) + end; + +function Succeeded(Status : HRESULT) : BOOLEAN; + begin + Succeeded:=Status and HRESULT($80000000)=0; + end; + +function Failed(Status : HRESULT) : BOOLEAN; + begin + Failed:=Status and HRESULT($80000000)<>0; + end; + +function RegisterDragDrop(hwnd: HWND; pDropTarget: IDropTarget): WINOLEAPI; +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); +end; + +function RevokeDragDrop(hwnd: HWND): WINOLEAPI; +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); +end; + +function DoDragDrop(pDataObj: IDataObject; pDropSource: IDropSource; + dwOKEffects: DWORD; pdwEffect: LPDWORD): WINOLEAPI; +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); +end; + +function OleInitialize(pvReserved: LPVOID): WINOLEAPI; +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); +end; + +procedure OleUninitialize; +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); +end; + +procedure ReleaseStgMedium(_para1: LPSTGMEDIUM); +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); +end; + +function OleSetClipboard(pDataObj: IDataObject): WINOLEAPI; +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); +end; + +function OleGetClipboard(out ppDataObj: IDataObject): WINOLEAPI; +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); +end; + +function OleFlushClipboard: WINOLEAPI; +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); +end; + +function OleIsCurrentClipboard(pDataObj: IDataObject): WINOLEAPI; +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); +end; + +function CreateStreamOnHGlobal(hGlobal: HGLOBAL; fDeleteOnRelease: BOOL; out + stm: IStream): WINOLEAPI; +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); +end; + +function CoCreateInstance(const _para1: TCLSID; _para2: IUnknown; + _para3: DWORD; const _para4: TIID; out _para5): HRESULT; +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); +end; + + +function RenderOLEData(Tree: TObject; const FormatEtcIn: TFormatEtc; out + Medium: TStgMedium; ForClipboard: Boolean): HResult; +{ + //--------------- local function -------------------------------------------- + + procedure WriteNodes(Stream: TStream); + + var + Selection: TNodeArray; + I: Integer; + + begin + with TVirtualTreeAccess(Tree) do + begin + if ForClipboard then + Selection := GetSortedCutCopySet(True) + else + Selection := GetSortedSelection(True); + for I := 0 to High(Selection) do + WriteNode(Stream, Selection[I]); + end; + end; + + //--------------- end local function ---------------------------------------- +} +var + Data: PCardinal; + ResPointer: Pointer; + ResSize: Integer; + OLEStream: IStream; + VCLStream: TStream; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + VCLStream := nil; + try + Medium.PunkForRelease := nil; + // Return data in one of the supported storage formats, prefer IStream. + if FormatEtcIn.tymed and TYMED_ISTREAM <> 0 then + begin + // Create an IStream on a memory handle (here it is 0 which indicates to implicitely allocated a handle). + // Do not use TStreamAdapter as it is not compatible with OLE (when flushing the clipboard OLE wants the HGlobal + // back which is not supported by TStreamAdapater). + CreateStreamOnHGlobal(0, True, OLEStream); + + VCLStream := TOLEStream.Create(OLEStream); + WriteNodes(VCLStream); + // Rewind stream. + VCLStream.Position := 0; + Medium.tymed := TYMED_ISTREAM; + IUnknown(Medium.Pstm) := OLEStream; + Result := S_OK; + end + else + begin + VCLStream := TMemoryStream.Create; + WriteNodes(VCLStream); + ResPointer := TMemoryStream(VCLStream).Memory; + ResSize := VCLStream.Position; + + // Allocate memory to hold the string. + if ResSize > 0 then + begin + Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, ResSize + SizeOf(Cardinal)); + Data := GlobalLock(Medium.hGlobal); + // Store the size of the data too, for easy retrival. + Data^ := ResSize; + Inc(Data); + Move(ResPointer^, Data^, ResSize); + GlobalUnlock(Medium.hGlobal); + Medium.tymed := TYMED_HGLOBAL; + + Result := S_OK; + end + else + Result := E_FAIL; + end; + finally + // We can free the VCL stream here since it was either a pure memory stream or only a wrapper around + // the OLEStream which exists independently. + VCLStream.Free; + end; + } +end; + + +type + // needed to handle OLE global memory objects + TOLEMemoryStream = class(TCustomMemoryStream) + public + function Write(const Buffer; Count: Integer): Longint; override; + end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TOLEMemoryStream.Write(const Buffer; Count: Integer): Integer; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + // raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError)); +end; + + +function GetStreamFromMedium(Medium: TStgMedium): TStream; + +var + Data: Pointer; + I: Integer; +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); +{ + Result := nil; + if Medium.tymed = TYMED_ISTREAM then + Result := TOLEStream.Create(IUnknown(Medium.Pstm) as IStream) + else + begin + Data := GlobalLock(Medium.hGlobal); + if Assigned(Data) then + begin + // Get the total size of data to retrieve. + I := PCardinal(Data)^; + Inc(PCardinal(Data)); + Result := TOLEMemoryStream.Create; + TOLEMemoryStream(Result).SetPointer(Data, I); + end; + end; +} +end; + +procedure UnlockMediumData(Medium: TStgMedium); +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); +{ + if Medium.tymed = TYMED_HGLOBAL then + GlobalUnlock(Medium.hGlobal); + } +end; + +function GetTreeFromDataObject(const DataObject: IDataObject; + var Format: TFormatEtc): TObject; + +var + Medium: TStgMedium; + Data: PVTReference; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + Result := nil; + if Assigned(DataObject) then + begin + Format.cfFormat := CF_VTREFERENCE; + if DataObject.GetData(Format, Medium) = S_OK then + begin + Data := GlobalLock(Medium.hGlobal); + if Assigned(Data) then + begin + if Data.Process = GetCurrentProcessID then + Result := Data.Tree; + GlobalUnlock(Medium.hGlobal); + end; + ReleaseStgMedium(@Medium); + end; + end; + } +end; + +function AllocateGlobal(Data: Pointer; DataSize: Cardinal): HGLOBAL; +var + P:Pointer; +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + Result := GlobalAlloc(GHND or GMEM_SHARE, DataSize); + P := GlobalLock(Result); + Move(Data^, P^, DataSize); + GlobalUnlock(Result); + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +// OLE drag and drop support classes +// This is quite heavy stuff (compared with the VCL implementation) but is much better suited to fit the needs +// of DD'ing various kinds of virtual data and works also between applications. + +//----------------- TEnumFormatEtc ------------------------------------------------------------------------------------- + +constructor TEnumFormatEtc.Create(Tree: TObject; AFormatEtcArray: TFormatEtcArray); + +var + I: Integer; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + inherited Create; + + FTree := Tree; + // Make a local copy of the format data. + SetLength(FFormatEtcArray, Length(AFormatEtcArray)); + for I := 0 to High(AFormatEtcArray) do + FFormatEtcArray[I] := AFormatEtcArray[I]; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult; + +var + AClone: TEnumFormatEtc; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + Result := S_OK; + try + AClone := TEnumFormatEtc.Create(nil, FFormatEtcArray); + AClone.FCurrentIndex := FCurrentIndex; + Enum := AClone as IEnumFormatEtc; + except + Result := E_FAIL; + end; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Next(celt: LongWord; out elt: FormatEtc; out pceltFetched: LongWord): HResult; + +var + CopyCount: LongWord; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + Result := S_FALSE; + CopyCount := Length(FFormatEtcArray) - FCurrentIndex; + if celt < CopyCount then + CopyCount := celt; + if CopyCount > 0 then + begin + Move(FFormatEtcArray[FCurrentIndex], elt, CopyCount * SizeOf(TFormatEtc)); + Inc(FCurrentIndex, CopyCount); + Result := S_OK; + end; + //todo_lcl_check Delphi treats pceltFetched an PInteger. Implemented like in fpc.activex. What heappens with + // a C Program call with a NULL in pCeltFetcjed?? + //Answer: Yes. Is necessary a check here + if @pceltFetched <> nil then + pceltFetched := CopyCount; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Reset: HResult; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + FCurrentIndex := 0; + Result := S_OK; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Skip(celt: LongWord): HResult; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + if FCurrentIndex + celt < High(FFormatEtcArray) then + begin + Inc(FCurrentIndex, celt); + Result := S_Ok; + end + else + Result := S_FALSE; + } +end; + + +//----------------- TVTDataObject -------------------------------------------------------------------------------------- + +constructor TVTDataObject.Create(AOwner: TObject; ForClipboard: Boolean); + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + inherited Create; + + FOwner := AOwner; + FForClipboard := ForClipboard; + TVirtualTreeAccess(FOwner).GetNativeClipboardFormats(FFormatEtcArray); + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVTDataObject.Destroy; + +var + I: Integer; + StgMedium: PStgMedium; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + // Cancel a pending clipboard operation if this data object was created for the clipboard and + // is freed because something else is placed there. + if FForClipboard and not (tsClipboardFlushing in TVirtualTreeAccess(FOwner).TreeStates) then + TVirtualTreeAccess(FOwner).CancelCutOrCopy; + + // Release any internal clipboard formats + for I := 0 to High(FormatEtcArray) do + begin + StgMedium := FindInternalStgMedium(FormatEtcArray[I].cfFormat); + if Assigned(StgMedium) then + ReleaseStgMedium(StgMedium); + end; + + FormatEtcArray := nil; + inherited; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.CanonicalIUnknown(TestUnknown: IUnknown): IUnknown; + +// Uses COM object identity: An explicit call to the IUnknown::QueryInterface method, requesting the IUnknown +// interface, will always return the same pointer. + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + if Assigned(TestUnknown) then + begin + if TestUnknown.QueryInterface(IUnknown, Result) = 0 then + Result._Release // Don't actually need it just need the pointer value + else + Result := TestUnknown + end + else + Result := TestUnknown + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + Result := (FormatEtc1.cfFormat = FormatEtc2.cfFormat) and (FormatEtc1.ptd = FormatEtc2.ptd) and + (FormatEtc1.dwAspect = FormatEtc2.dwAspect) and (FormatEtc1.lindex = FormatEtc2.lindex) and + (FormatEtc1.tymed and FormatEtc2.tymed <> 0); + + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer; + +var + I: integer; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + Result := -1; + for I := 0 to High(FormatEtcArray) do + begin + if EqualFormatEtc(TestFormatEtc, FormatEtcArray[I]) then + begin + Result := I; + Break; + end + end; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.FindInternalStgMedium(Format: TClipFormat): PStgMedium; + +var + I: integer; +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + Result := nil; + for I := 0 to High(InternalStgMediumArray) do + begin + if Format = InternalStgMediumArray[I].Format then + begin + Result := @InternalStgMediumArray[I].Medium; + Break; + end + end; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.HGlobalClone(HGlobal: THandle): THandle; + +// Returns a global memory block that is a copy of the passed memory block. + +var + Size: Cardinal; + Data, + NewData: PChar; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + Size := GlobalSize(HGlobal); + Result := GlobalAlloc(GPTR, Size); + Data := GlobalLock(hGlobal); + try + NewData := GlobalLock(Result); + try + Move(Data^, NewData^, Size); + finally + GlobalUnLock(Result); + end + finally + GlobalUnLock(hGlobal); + end; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium; + var OLEResult: HResult): Boolean; + +// Tries to render one of the formats which have been stored via the SetData method. +// Since this data is already there it is just copied or its reference count is increased (depending on storage medium). + +var + InternalMedium: PStgMedium; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + + Result := True; + InternalMedium := FindInternalStgMedium(FormatEtcIn.cfFormat); + if Assigned(InternalMedium) then + OLEResult := StgMediumIncRef(InternalMedium^, Medium, False, Self as IDataObject) + else + Result := False; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium; + CopyInMedium: Boolean; DataObject: IDataObject): HRESULT; + +// InStgMedium is the data that is requested, OutStgMedium is the data that we are to return either a copy of or +// increase the IDataObject's reference and send ourselves back as the data (unkForRelease). The InStgMedium is usually +// the result of a call to find a particular FormatEtc that has been stored locally through a call to SetData. +// If CopyInMedium is not true we already have a local copy of the data when the SetData function was called (during +// that call the CopyInMedium must be true). Then as the caller asks for the data through GetData we do not have to make +// copy of the data for the caller only to have them destroy it then need us to copy it again if necessary. +// This way we increase the reference count to ourselves and pass the STGMEDIUM structure initially stored in SetData. +// This way when the caller frees the structure it sees the unkForRelease is not nil and calls Release on the object +// instead of destroying the actual data. + +var + Len: Integer; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + Result := S_OK; + + // Simply copy all fields to start with. + OutStgMedium := InStgMedium; + // The data handled here always results from a call of SetData we got. This ensures only one storage format + // is indicated and hence the case statement below is safe (IDataObject.GetData can optionally use several + // storage formats). + case InStgMedium.tymed of + TYMED_HGLOBAL: + begin + if CopyInMedium then + begin + // Generate a unique copy of the data passed + OutStgMedium.hGlobal := HGlobalClone(InStgMedium.hGlobal); + if OutStgMedium.hGlobal = 0 then + Result := E_OUTOFMEMORY + end + else + // Don't generate a copy just use ourselves and the copy previously saved. + OutStgMedium.PunkForRelease := Pointer(DataObject); // Does not increase RefCount. + end; + TYMED_FILE: + begin + //todo_lcl_check + Len := Length(WideString(InStgMedium.lpszFileName)) + 1; // Don't forget the terminating null character. + OutStgMedium.lpszFileName := CoTaskMemAlloc(2 * Len); + Move(InStgMedium.lpszFileName^, OutStgMedium.lpszFileName^, 2 * Len); + end; + TYMED_ISTREAM: + IUnknown(OutStgMedium.Pstm)._AddRef; + TYMED_ISTORAGE: + IUnknown(OutStgMedium.Pstg)._AddRef; + TYMED_GDI: + if not CopyInMedium then + // Don't generate a copy just use ourselves and the previously saved data. + OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount. + else + Result := DV_E_TYMED; // Don't know how to copy GDI objects right now. + TYMED_MFPICT: + if not CopyInMedium then + // Don't generate a copy just use ourselves and the previously saved data. + OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount. + else + Result := DV_E_TYMED; // Don't know how to copy MetaFile objects right now. + TYMED_ENHMF: + if not CopyInMedium then + // Don't generate a copy just use ourselves and the previously saved data. + OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount. + else + Result := DV_E_TYMED; // Don't know how to copy enhanced metafiles objects right now. + else + Result := DV_E_TYMED; + end; + + if (Result = S_OK) and Assigned(OutStgMedium.PunkForRelease) then + IUnknown(OutStgMedium.PunkForRelease)._AddRef; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.DAdvise(const FormatEtc: TFormatEtc; advf: DWord; const advSink: IAdviseSink; + out dwConnection: DWord): HResult; + +// Advise sink management is greatly simplified by the IDataAdviseHolder interface. +// We use this interface and forward all concerning calls to it. + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + Result := S_OK; + if FAdviseHolder = nil then + Result := CreateDataAdviseHolder(FAdviseHolder); + if Result = S_OK then + Result := FAdviseHolder.Advise(Self as IDataObject, FormatEtc, advf, advSink, dwConnection); + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.DUnadvise(dwConnection: DWord): HResult; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + if FAdviseHolder = nil then + Result := E_NOTIMPL + else + Result := FAdviseHolder.Unadvise(dwConnection); + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.EnumDAvise(Out enumAdvise : IEnumStatData):HResult; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + if FAdviseHolder = nil then + Result := OLE_E_ADVISENOTSUPPORTED + else + Result := FAdviseHolder.EnumAdvise(enumAdvise); + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.EnumFormatEtc(Direction: DWord; out EnumFormatEtc: IEnumFormatEtc): HResult; + +var + NewList: TEnumFormatEtc; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + Result := E_FAIL; + if Direction = DATADIR_GET then + begin + NewList := TEnumFormatEtc.Create(TVirtualTreeAccess(FOwner), FormatEtcArray); + EnumFormatEtc := NewList as IEnumFormatEtc; + Result := S_OK; + end + else + EnumFormatEtc := nil; + if EnumFormatEtc = nil then + Result := OLE_S_USEREG; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +Function TVTDataObject.GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + //Result := DATA_S_SAMEFORMATETC; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; + +// Data is requested by clipboard or drop target. This method dispatchs the call +// depending on the data being requested. + +var + I: Integer; + Data: PVTReference; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + // The tree reference format is always supported and returned from here. + { + if FormatEtcIn.cfFormat = CF_VTREFERENCE then + begin + // Note: this format is not used while flushing the clipboard to avoid a dangling reference + // when the owner tree is destroyed before the clipboard data is replaced with something else. + if tsClipboardFlushing in TVirtualTreeAccess(FOwner).TreeStates then + Result := E_FAIL + else + begin + Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference)); + Data := GlobalLock(Medium.hGlobal); + Data.Process := GetCurrentProcessID; + Data.Tree := TBaseVirtualTree(FOwner); + GlobalUnlock(Medium.hGlobal); + Medium.tymed := TYMED_HGLOBAL; + Medium.PunkForRelease := nil; + Result := S_OK; + end; + end + else + begin + try + // See if we accept this type and if not get the correct return value. + Result := QueryGetData(FormatEtcIn); + if Result = S_OK then + begin + for I := 0 to High(FormatEtcArray) do + begin + if EqualFormatEtc(FormatEtcIn, FormatEtcArray[I]) then + begin + if not RenderInternalOLEData(FormatEtcIn, Medium, Result) then + Result := TVirtualTreeAccess(FOwner).RenderOLEData(FormatEtcIn, Medium, FForClipboard); + Break; + end; + end + end + except + FillChar(Medium, SizeOf(Medium), #0); + Result := E_FAIL; + end; + end; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + //Result := E_NOTIMPL; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.QueryGetData(const FormatEtc: TFormatEtc): HResult; + +var + I: Integer; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + Result := DV_E_CLIPFORMAT; + for I := 0 to High(FFormatEtcArray) do + begin + if FormatEtc.cfFormat = FFormatEtcArray[I].cfFormat then + begin + if (FormatEtc.tymed and FFormatEtcArray[I].tymed) <> 0 then + begin + if FormatEtc.dwAspect = FFormatEtcArray[I].dwAspect then + begin + if FormatEtc.lindex = FFormatEtcArray[I].lindex then + begin + Result := S_OK; + Break; + end + else + Result := DV_E_LINDEX; + end + else + Result := DV_E_DVASPECT; + end + else + Result := DV_E_TYMED; + end; + end + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; + +// Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement +// IDropSourceHelper and allows to set a special format for optimized moves during a shell transfer. + +var + Index: Integer; + LocalStgMedium: PStgMedium; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + // See if we already have a format of that type available. + Index := FindFormatEtc(FormatEtc, FormatEtcArray); + if Index > - 1 then + begin + // Just use the TFormatEct in the array after releasing the data. + LocalStgMedium := FindInternalStgMedium(FormatEtcArray[Index].cfFormat); + if Assigned(LocalStgMedium) then + begin + ReleaseStgMedium(LocalStgMedium); + FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0); + end; + end + else + begin + // It is a new format so create a new TFormatCollectionItem, copy the + // FormatEtc parameter into the new object and and put it in the list. + SetLength(FFormatEtcArray, Length(FormatEtcArray) + 1); + FormatEtcArray[High(FormatEtcArray)] := FormatEtc; + + // Create a new InternalStgMedium and initialize it and associate it with the format. + SetLength(FInternalStgMediumArray, Length(InternalStgMediumArray) + 1); + InternalStgMediumArray[High(InternalStgMediumArray)].Format := FormatEtc.cfFormat; + LocalStgMedium := @InternalStgMediumArray[High(InternalStgMediumArray)].Medium; + FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0); + end; + + if DoRelease then + begin + // We are simply being given the data and we take control of it. + LocalStgMedium^ := Medium; + Result := S_OK + end + else + begin + // We need to reference count or copy the data and keep our own references to it. + Result := StgMediumIncRef(Medium, LocalStgMedium^, True, Self as IDataObject); + + // Can get a circular reference if the client calls GetData then calls SetData with the same StgMedium. + // Because the unkForRelease for the IDataObject can be marshalled it is necessary to get pointers that + // can be correctly compared. See the IDragSourceHelper article by Raymond Chen at MSDN. + if Assigned(LocalStgMedium.PunkForRelease) then + begin + if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.PunkForRelease)) then + IUnknown(LocalStgMedium.PunkForRelease) := nil; // release the interface + end; + end; + + // Tell all registered advice sinks about the data change. + if Assigned(FAdviseHolder) then + FAdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0); + } +end; + + +//----------------- TVTDragManager ------------------------------------------------------------------------------------- + +constructor TVTDragManager.Create(AOwner: TObject); + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + inherited Create; + FOwner := AOwner; + + // Create an instance of the drop target helper interface. This will fail but not harm on systems which do + // not support this interface (everything below Windows 2000); + CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IID_IDropTargetHelper, FDropTargetHelper); + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVTDragManager.Destroy; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + // Set the owner's reference to us to nil otherwise it will access an invalid pointer + // after our desctruction is complete. + TVirtualTreeAccess(FOwner).FreeDragManager; + inherited; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetDataObject: IDataObject; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + // When the owner tree starts a drag operation then it gets a data object here to pass it to the OLE subsystem. + // In this case there is no local reference to a data object and one is created (but not stored). + // If there is a local reference then the owner tree is currently the drop target and the stored interface is + // that of the drag initiator. + if Assigned(FDataObject) then + Result := FDataObject + else + begin + Result := TVirtualTreeAccess(FOwner).DoCreateDataObject; + if Result = nil then + Result := TVTDataObject.Create(FOwner, False) as IDataObject; + end; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetDragSource: TObject; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + //Result := FDragSource; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetDropTargetHelperSupported: Boolean; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + //Result := Assigned(FDropTargetHelper); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetIsDropTarget: Boolean; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + //Result := FIsDropTarget; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.DragEnter(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint; + var Effect: LongWord): HResult; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + FDataObject := DataObject; + FIsDropTarget := True; + + SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @FFullDragging, 0); + // If full dragging of window contents is disabled in the system then our tree windows will be locked + // and cannot be updated during a drag operation. With the following call painting is again enabled. + if not FFullDragging then + LockWindowUpdate(0); + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.DragEnter(TBaseVirtualTree(FOwner).Handle, DataObject, Pt, Effect); + + FDragSource := TVirtualTreeAccess(FOwner).GetTreeFromDataObject(DataObject); + Result := TVirtualTreeAccess(FOwner).DragEnter(KeyState, Pt, Effect); + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.DragLeave: HResult; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.DragLeave; + + TVirtualTreeAccess(FOwner).DragLeave; + FIsDropTarget := False; + FDragSource := nil; + FDataObject := nil; + Result := NOERROR; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.DragOver(KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.DragOver(Pt, Effect); + + Result := TVirtualTreeAccess(FOwner).DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect); + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.Drop(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint; + var Effect: LongWord): HResult; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.Drop(DataObject, Pt, Effect); + + Result := TVirtualTreeAccess(FOwner).DragDrop(DataObject, KeyState, Pt, Effect); + FIsDropTarget := False; + FDataObject := nil; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragManager.ForceDragLeave; + +// Some drop targets, e.g. Internet Explorer leave a drag image on screen instead removing it when they receive +// a drop action. This method calls the drop target helper's DragLeave method to ensure it removes the drag image from +// screen. Unfortunately, sometimes not even this does help (e.g. when dragging text from VT to a text field in IE). + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.DragLeave; + } +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GiveFeedback(Effect: Integer): HResult; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + //Result := DRAGDROP_S_USEDEFAULTCURSORS; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult; + +var + RButton, + LButton: Boolean; + +begin + Logger.SendError([lcOle],'Ole function called in Linux'); + Logger.SendCallStack([lcOle],'Stack'); + { + LButton := (KeyState and MK_LBUTTON) <> 0; + RButton := (KeyState and MK_RBUTTON) <> 0; + + // Drag'n drop canceled by pressing both mouse buttons or Esc? + if (LButton and RButton) or EscapePressed then + Result := DRAGDROP_S_CANCEL + else + // Drag'n drop finished? + if not (LButton or RButton) then + Result := DRAGDROP_S_DROP + else + Result := S_OK; + } +end; + + +end. + diff --git a/components/virtualtreeview-unstable/vtlogger.pas b/components/virtualtreeview-unstable/vtlogger.pas index 487f06722..b60b164ae 100644 --- a/components/virtualtreeview-unstable/vtlogger.pas +++ b/components/virtualtreeview-unstable/vtlogger.pas @@ -32,6 +32,7 @@ const lcColumnPosition = 17; lcTimer = 18; lcDrag = 19; + lcOle = 20; var Logger: TLCLLogger;