From 4c0ee502c74faa957c3ffa1739481e39232a2792 Mon Sep 17 00:00:00 2001 From: blikblum Date: Sun, 9 Sep 2007 13:27:06 +0000 Subject: [PATCH] * Moved OLE code to include files * Cleaned defines git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@263 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- .../virtualtreeview-unstable/VTConfig.inc | 5 - .../virtualtreeview-unstable/VirtualTrees.pas | 1157 +---------------- .../include/intf/win32/dragmanager.inc | 722 ++++++++++ .../include/intf/win32/intf_uses.inc | 1 + .../include/intf/win32/olemethods.inc | 396 ++++++ .../virtualtreeview_package.lpk | 1 + 6 files changed, 1125 insertions(+), 1157 deletions(-) create mode 100644 components/virtualtreeview-unstable/include/intf/win32/dragmanager.inc create mode 100644 components/virtualtreeview-unstable/include/intf/win32/intf_uses.inc create mode 100644 components/virtualtreeview-unstable/include/intf/win32/olemethods.inc diff --git a/components/virtualtreeview-unstable/VTConfig.inc b/components/virtualtreeview-unstable/VTConfig.inc index 138c0c529..61fca78f3 100644 --- a/components/virtualtreeview-unstable/VTConfig.inc +++ b/components/virtualtreeview-unstable/VTConfig.inc @@ -28,15 +28,10 @@ {$define EnableOLE} {.$define EnableNativeTVM} {.$define EnablePrint} -{$define NeedWindows} {.$define EnableNCFunctions} {$define EnableAdvancedGraphics} {$define EnableAlphaBlend} -{$define EnableHeader} -{$define EnableTimer} {.$define EnableAccessible} -{$define UseExternalDragManager} -{$define UseDelphiCompat} //under linux the performance is poor with threading enabled {$ifdef Windows} diff --git a/components/virtualtreeview-unstable/VirtualTrees.pas b/components/virtualtreeview-unstable/VirtualTrees.pas index 9bb916294..11502f9de 100644 --- a/components/virtualtreeview-unstable/VirtualTrees.pas +++ b/components/virtualtreeview-unstable/VirtualTrees.pas @@ -114,20 +114,11 @@ interface {$endif COMPILER_7_UP} uses - {$ifdef UseExternalDragManager} - virtualdragmanager, - {$else} - Windows, + {$i intf_uses.inc} ActiveX, OleUtils, - {$endif} - {$ifdef UseDelphiCompat} DelphiCompat, - {$else} - Windows, - DelphiCompat, - {$endif} - lclext, + LclExt, virtualpanningwindow, vtlogger, LCLType, LResources, LCLIntf, LMessages, Types, SysUtils, Classes, Graphics, Controls, Forms, ImgList, StdCtrls, Menus, Printers, @@ -805,7 +796,7 @@ type 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; {$ifdef VER2_0}var{$else}const{$endif} Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall; + function SetData(const FormatEtc: TFormatEtc; const Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall; end; // TVTDragManager is a class to manage drag and drop in a Virtual Treeview. @@ -5451,726 +5442,7 @@ end; {$endif UseLocalMemoryManager} -{$ifndef UseExternalDragManager} -//---------------------------------------------------------------------------------------------------------------------- - -// 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: TBaseVirtualTree; AFormatEtcArray: TFormatEtcArray); - -var - I: Integer; - -begin - 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 - 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 - 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 - FCurrentIndex := 0; - Result := S_OK; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TEnumFormatEtc.Skip(celt: LongWord): HResult; - -begin - if FCurrentIndex + celt < High(FFormatEtcArray) then - begin - Inc(FCurrentIndex, celt); - Result := S_Ok; - end - else - Result := S_FALSE; -end; - - - -//----------------- TVTDataObject -------------------------------------------------------------------------------------- - -constructor TVTDataObject.Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean); - -begin - inherited Create; - - FOwner := AOwner; - FForClipboard := ForClipboard; - FOwner.GetNativeClipboardFormats(FFormatEtcArray); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVTDataObject.Destroy; - -var - I: Integer; - StgMedium: PStgMedium; - -begin - // 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 FOwner.FStates) then - 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 - 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 - 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 - 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 - 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 - 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 - 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 - 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 - 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 - if FAdviseHolder = nil then - Result := E_NOTIMPL - else - Result := FAdviseHolder.Unadvise(dwConnection); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.EnumDAvise(Out enumAdvise : IEnumStatData):HResult; - -begin - 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 - Result := E_FAIL; - if Direction = DATADIR_GET then - begin - NewList := TEnumFormatEtc.Create(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 - 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 - // 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 FOwner.FStates then - Result := E_FAIL - else - begin - Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference)); - Data := GlobalLock(Medium.hGlobal); - Data.Process := GetCurrentProcessID; - Data.Tree := 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 := 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 - Result := E_NOTIMPL; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.QueryGetData(const FormatEtc: TFormatEtc): HResult; - -var - I: Integer; - -begin - 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; {$ifdef VER2_0}var{$else}const{$endif} 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 - // 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: TBaseVirtualTree); - -begin - 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 - // Set the owner's reference to us to nil otherwise it will access an invalid pointer - // after our desctruction is complete. - Pointer(FOwner.FDragManager) := nil; - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GetDataObject: IDataObject; - -begin - // 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 := FOwner.DoCreateDataObject; - if Result = nil then - Result := TVTDataObject.Create(FOwner, False) as IDataObject; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GetDragSource: TBaseVirtualTree; - -begin - Result := FDragSource; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GetDropTargetHelperSupported: Boolean; - -begin - Result := Assigned(FDropTargetHelper); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GetIsDropTarget: Boolean; - -begin - Result := FIsDropTarget; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.DragEnter(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint; - var Effect: LongWord): HResult; - -begin - 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(FOwner.Handle, DataObject, Pt, Effect); - - FDragSource := FOwner.GetTreeFromDataObject(DataObject); - Result := FOwner.DragEnter(KeyState, Pt, Effect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.DragLeave: HResult; - -begin - if Assigned(FDropTargetHelper) and FFullDragging then - FDropTargetHelper.DragLeave; - - FOwner.DragLeave; - FIsDropTarget := False; - FDragSource := nil; - FDataObject := nil; - Result := NOERROR; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.DragOver(KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult; - -begin - if Assigned(FDropTargetHelper) and FFullDragging then - FDropTargetHelper.DragOver(Pt, Effect); - - Result := FOwner.DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.Drop(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint; - var Effect: LongWord): HResult; - -begin - if Assigned(FDropTargetHelper) and FFullDragging then - FDropTargetHelper.Drop(DataObject, Pt, Effect); - - Result := 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 - if Assigned(FDropTargetHelper) and FFullDragging then - FDropTargetHelper.DragLeave; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GiveFeedback(Effect: Integer): HResult; - -begin - Result := DRAGDROP_S_USEDEFAULTCURSORS; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult; - -var - RButton, - LButton: Boolean; - -begin - 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; -{$endif} //UseExternalDragManager +{$i dragmanager.inc} //----------------- TVirtualTreeHintWindow ----------------------------------------------------------------------------- @@ -20521,37 +19793,7 @@ end; //---------------------------------------------------------------------------------------------------------------------- -function TBaseVirtualTree.GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree; - -// Returns the owner/sender of the given data object by means of a special clipboard format -// or nil if the sender is in another process or no virtual tree at all. - -var - Medium: TStgMedium; - Data: PVTReference; - -begin - {$ifdef UseExternalDragManager} - Result:=TBaseVirtualTree(VirtualDragManager.GetTreeFromDataObject(DataObject,StandardOLEFormat)); - {$else} - Result := nil; - if Assigned(DataObject) then - begin - StandardOLEFormat.cfFormat := CF_VTREFERENCE; - if DataObject.GetData(StandardOLEFormat, 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; - {$endif} -end; +{$i olemethods.inc} //---------------------------------------------------------------------------------------------------------------------- @@ -22679,108 +21921,6 @@ end; //---------------------------------------------------------------------------------------------------------------------- -function TBaseVirtualTree.RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; - ForClipboard: Boolean): HResult; - -// Returns a memory expression of all currently selected nodes in the Medium structure. -// Note: The memory requirement of this method might be very high. This depends however on the requested storage format. -// For HGlobal (a global memory block) we need to render first all nodes to local memory and copy this then to -// the global memory in Medium. This is necessary because we have first to determine how much -// memory is needed before we can allocate it. Hence for a short moment we need twice the space as used by the -// nodes alone (plus the amount the nodes need in the tree anyway)! -// With IStream this does not happen. We directly stream out the nodes and pass the constructed stream along. - - //--------------- local function -------------------------------------------- - - procedure WriteNodes(Stream: TStream); - - var - Selection: TNodeArray; - I: Integer; - - begin - if ForClipboard then - Selection := GetSortedCutCopySet(True) - else - Selection := GetSortedSelection(True); - for I := 0 to High(Selection) do - WriteNode(Stream, Selection[I]); - end; - - //--------------- end local function ---------------------------------------- -{$ifndef UseExternalDragManager} -var - Data: PCardinal; - ResPointer: Pointer; - ResSize: Integer; - OLEStream: IStream; - VCLStream: TStream; -{$endif} -begin - FillChar(Medium, SizeOf(Medium), 0); - // We can render the native clipboard format in two different storage media. - if (FormatEtcIn.cfFormat = CF_VIRTUALTREE) and (FormatEtcIn.tymed and (TYMED_HGLOBAL or TYMED_ISTREAM) <> 0) then - begin - {$ifdef UseExternalDragManager} - //Separated function to help isolate OLE code - virtualdragmanager.RenderOLEData(Self,FormatEtcIn,Medium,ForClipboard); - {$else} - 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; - {$endif} - end - else // Ask application descendants to render self defined formats. - Result := DoRenderOLEData(FormatEtcIn, Medium, ForClipboard); -end; - -//---------------------------------------------------------------------------------------------------------------------- - procedure TBaseVirtualTree.ResetRangeAnchor; // Called when there is no selected node anymore and the selection range anchor needs a new value. @@ -28352,175 +27492,6 @@ begin end; end; -//---------------------------------------------------------------------------------------------------------------------- -{$ifndef UseExternalDragManager} -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 - //raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError)); - raise EStreamError.Create(SCantWriteResourceStreamError); -end; - -{$endif} - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ProcessOLEData(Source: TBaseVirtualTree; DataObject: IDataObject; TargetNode: PVirtualNode; - Mode: TVTNodeAttachMode; Optimized: Boolean): Boolean; - -// Recreates the (sub) tree structure serialized into memory and provided by DataObject. The new nodes are attached to -// the passed node or FRoot if TargetNode is nil according to Mode. Optimized can be set to True if the entire operation -// happens within the same process (i.e. sender and receiver of the OLE operation are located in the same process). -// Optimize = True makes only sense if the operation to carry out is a move hence it is also the indication of the -// operation to be done here. Source is the source of the OLE data and only of use (and usually assigned) when -// an OLE operation takes place in the same application. -// Returns True on success, i.e. the CF_VIRTUALTREE format is supported by the data object and the structure could be -// recreated, otherwise False. - -var - Medium: TStgMedium; - Stream: TStream; - {$ifndef UseExternalDragManager} - Data: Pointer; - {$endif} - Node: PVirtualNode; - Nodes: TNodeArray; - I: Integer; - Res: HRESULT; - ChangeReason: TChangeReason; - -begin - Nodes := nil; - // Check the data format available by the data object. - with StandardOLEFormat do - begin - // Read best format. - cfFormat := CF_VIRTUALTREE; - end; - Result := DataObject.QueryGetData(StandardOLEFormat) = S_OK; - if Result and not (toReadOnly in FOptions.FMiscOptions) then - begin - BeginUpdate; - Result := False; - try - if TargetNode = nil then - TargetNode := FRoot; - if TargetNode = FRoot then - begin - case Mode of - amInsertBefore: - Mode := amAddChildFirst; - amInsertAfter: - Mode := amAddChildLast; - end; - end; - - // Optimized means source is known and in the same process so we can access its pointers, which avoids duplicating - // the data while doing a serialization. Can only be used with cut'n paste and drag'n drop with move effect. - if Optimized then - begin - if tsOLEDragging in Source.FStates then - Nodes := Source.FDragSelection - else - Nodes := Source.GetSortedCutCopySet(True); - - if Mode in [amInsertBefore,amAddChildLast] then - begin - for I := 0 to High(Nodes) do - if not HasAsParent(TargetNode, Nodes[I]) then - Source.MoveTo(Nodes[I], TargetNode, Mode, False); - end - else - begin - for I := High(Nodes) downto 0 do - if not HasAsParent(TargetNode, Nodes[I]) then - Source.MoveTo(Nodes[I], TargetNode, Mode, False); - end; - Result := True; - end - else - begin - if Source = Self then - ChangeReason := crNodeCopied - else - ChangeReason := crNodeAdded; - Res := DataObject.GetData(StandardOLEFormat, Medium); - if Res = S_OK then - begin - case Medium.tymed of - TYMED_ISTREAM, // IStream interface - TYMED_HGLOBAL: // global memory block - begin - {$ifdef UseExternalDragManager} - Stream:=GetStreamFromMedium(Medium); - {$else} - Stream := nil; - if Medium.tymed = TYMED_ISTREAM then - Stream := 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)); - Stream := TOLEMemoryStream.Create; - TOLEMemoryStream(Stream).SetPointer(Data, I); - end; - end; - {$endif} - if Assigned(Stream) then - try - while Stream.Position < Stream.Size do - begin - Node := MakeNewNode; - InternalConnectNode(Node, TargetNode, Self, Mode); - InternalAddFromStream(Stream, VTTreeStreamVersion, Node); - // This seems a bit strange because of the callback for granting to add the node - // which actually comes after the node has been added. The reason is that the node must - // contain valid data otherwise I don't see how the application can make a funded decision. - if not DoNodeCopying(Node, TargetNode) then - DeleteNode(Node) - else - DoNodeCopied(Node); - StructureChange(Node, ChangeReason); - - // In order to maintain the same node order when restoring nodes in the case of amInsertAfter - // we have to move the reference node continously. Othwise we would end up with reversed node order. - if Mode = amInsertAfter then - TargetNode := Node; - end; - Result := True; - finally - Stream.Free; - {$ifdef UseExternalDragManager} - UnlockMediumData(Medium); - {$else} - if Medium.tymed = TYMED_HGLOBAL then - GlobalUnlock(Medium.hGlobal); - {$endif} - end; - end; - end; - ReleaseStgMedium(@Medium); - end; - end; - finally - EndUpdate; - end; - end; -end; - //---------------------------------------------------------------------------------------------------------------------- procedure TBaseVirtualTree.ReinitChildren(Node: PVirtualNode; Recursive: Boolean); @@ -30812,124 +29783,6 @@ end; //---------------------------------------------------------------------------------------------------------------------- -function TCustomVirtualStringTree.ContentToClipboard(Format: Word; Source: TVSTTextSourceType): HGLOBAL; - -// This method constructs a shareable memory object filled with string data in the required format. Supported are: -// CF_TEXT - plain ANSI text (Unicode text is converted using the user's current locale) -// CF_UNICODETEXT - plain Unicode text -// CF_CSV - comma separated plain ANSI text -// CF_VRTF + CF_RTFNOOBS - rich text (plain ANSI) -// CF_HTML - HTML text encoded using UTF-8 -// -// Result is the handle to a globally allocated memory block which can directly be used for clipboard and drag'n drop -// transfers. The caller is responsible for freeing the memory. If for some reason the content could not be rendered -// the Result is 0. - - //--------------- local function -------------------------------------------- - - procedure MakeFragment(var HTML: string); - - // Helper routine to build a properly-formatted HTML fragment. - - const - Version = 'Version:1.0'#13#10; - StartHTML = 'StartHTML:'; - EndHTML = 'EndHTML:'; - StartFragment = 'StartFragment:'; - EndFragment = 'EndFragment:'; - DocType = ''; - HTMLIntro = '' + - ''; - HTMLExtro = ''; - NumberLengthAndCR = 10; - - // Let the compiler determine the description length. - DescriptionLength = Length(Version) + Length(StartHTML) + Length(EndHTML) + Length(StartFragment) + - Length(EndFragment) + 4 * NumberLengthAndCR; - - var - Description: string; - StartHTMLIndex, - EndHTMLIndex, - StartFragmentIndex, - EndFragmentIndex: Integer; - - begin - // The HTML clipboard format is defined by using byte positions in the entire block where HTML text and - // fragments start and end. These positions are written in a description. Unfortunately the positions depend on the - // length of the description but the description may change with varying positions. - // To solve this dilemma the offsets are converted into fixed length strings which makes it possible to know - // the description length in advance. - StartHTMLIndex := DescriptionLength; // position 0 after the description - StartFragmentIndex := StartHTMLIndex + Length(DocType) + Length(HTMLIntro); - EndFragmentIndex := StartFragmentIndex + Length(HTML); - EndHTMLIndex := EndFragmentIndex + Length(HTMLExtro); - - Description := Version + - SysUtils.Format('%s%.8d', [StartHTML, StartHTMLIndex]) + #13#10 + - SysUtils.Format('%s%.8d', [EndHTML, EndHTMLIndex]) + #13#10 + - SysUtils.Format('%s%.8d', [StartFragment, StartFragmentIndex]) + #13#10 + - SysUtils.Format('%s%.8d', [EndFragment, EndFragmentIndex]) + #13#10; - HTML := Description + DocType + HTMLIntro + HTML + HTMLExtro; - end; - - //--------------- end local function ---------------------------------------- - -var - Data: Pointer; - DataSize: Cardinal; - S: string; - WS: WideString; - P: Pointer; - -begin - Result := 0; - case Format of - CF_TEXT: - begin - S := ContentToText(Source, #9) + #0; - Data := PChar(S); - DataSize := Length(S); - end; - CF_UNICODETEXT: - begin - WS := ContentToUnicode(Source, #9) + #0; - Data := PWideChar(WS); - DataSize := 2 * Length(WS); - end; - else - if Format = CF_CSV then - S := ContentToText(Source, ListSeparator) + #0 - else - if (Format = CF_VRTF) or (Format = CF_VRTFNOOBJS) then - S := ContentToRTF(Source) + #0 - else - if Format = CF_HTML then - begin - S := ContentToHTML(Source); - // Build a valid HTML clipboard fragment. - MakeFragment(S); - S := S + #0; - end; - Data := PChar(S); - DataSize := Length(S); - end; - - if DataSize > 0 then - begin - {$ifdef UseExternalDragManager} - Result:=AllocateGlobal(Data,DataSize); - {$else} - Result := GlobalAlloc(GHND or GMEM_SHARE, DataSize); - P := GlobalLock(Result); - Move(Data^, P^, DataSize); - GlobalUnlock(Result); - {$endif} - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - function TCustomVirtualStringTree.ContentToHTML(Source: TVSTTextSourceType; Caption: WideString = ''): string; // Renders the current tree content (depending on Source) as HTML text encoded in UTF-8. diff --git a/components/virtualtreeview-unstable/include/intf/win32/dragmanager.inc b/components/virtualtreeview-unstable/include/intf/win32/dragmanager.inc new file mode 100644 index 000000000..09eb8bec5 --- /dev/null +++ b/components/virtualtreeview-unstable/include/intf/win32/dragmanager.inc @@ -0,0 +1,722 @@ + + +//---------------------------------------------------------------------------------------------------------------------- + +// 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: TBaseVirtualTree; AFormatEtcArray: TFormatEtcArray); + +var + I: Integer; + +begin + 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 + 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 + 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 + FCurrentIndex := 0; + Result := S_OK; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Skip(celt: LongWord): HResult; + +begin + if FCurrentIndex + celt < High(FFormatEtcArray) then + begin + Inc(FCurrentIndex, celt); + Result := S_Ok; + end + else + Result := S_FALSE; +end; + + + +//----------------- TVTDataObject -------------------------------------------------------------------------------------- + +constructor TVTDataObject.Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean); + +begin + inherited Create; + + FOwner := AOwner; + FForClipboard := ForClipboard; + FOwner.GetNativeClipboardFormats(FFormatEtcArray); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVTDataObject.Destroy; + +var + I: Integer; + StgMedium: PStgMedium; + +begin + // 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 FOwner.FStates) then + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + if FAdviseHolder = nil then + Result := E_NOTIMPL + else + Result := FAdviseHolder.Unadvise(dwConnection); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.EnumDAvise(Out enumAdvise : IEnumStatData):HResult; + +begin + 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 + Result := E_FAIL; + if Direction = DATADIR_GET then + begin + NewList := TEnumFormatEtc.Create(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 + 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 + // 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 FOwner.FStates then + Result := E_FAIL + else + begin + Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference)); + Data := GlobalLock(Medium.hGlobal); + Data.Process := GetCurrentProcessID; + Data.Tree := 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 := 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 + Result := E_NOTIMPL; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.QueryGetData(const FormatEtc: TFormatEtc): HResult; + +var + I: Integer; + +begin + 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; {$ifdef VER2_0}var{$else}const{$endif} 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 + // 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: TBaseVirtualTree); + +begin + 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 + // Set the owner's reference to us to nil otherwise it will access an invalid pointer + // after our desctruction is complete. + Pointer(FOwner.FDragManager) := nil; + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetDataObject: IDataObject; + +begin + // 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 := FOwner.DoCreateDataObject; + if Result = nil then + Result := TVTDataObject.Create(FOwner, False) as IDataObject; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetDragSource: TBaseVirtualTree; + +begin + Result := FDragSource; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetDropTargetHelperSupported: Boolean; + +begin + Result := Assigned(FDropTargetHelper); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetIsDropTarget: Boolean; + +begin + Result := FIsDropTarget; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.DragEnter(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint; + var Effect: LongWord): HResult; + +begin + 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(FOwner.Handle, DataObject, Pt, Effect); + + FDragSource := FOwner.GetTreeFromDataObject(DataObject); + Result := FOwner.DragEnter(KeyState, Pt, Effect); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.DragLeave: HResult; + +begin + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.DragLeave; + + FOwner.DragLeave; + FIsDropTarget := False; + FDragSource := nil; + FDataObject := nil; + Result := NOERROR; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.DragOver(KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult; + +begin + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.DragOver(Pt, Effect); + + Result := FOwner.DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.Drop(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint; + var Effect: LongWord): HResult; + +begin + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.Drop(DataObject, Pt, Effect); + + Result := 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 + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.DragLeave; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GiveFeedback(Effect: Integer): HResult; + +begin + Result := DRAGDROP_S_USEDEFAULTCURSORS; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult; + +var + RButton, + LButton: Boolean; + +begin + 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; + + diff --git a/components/virtualtreeview-unstable/include/intf/win32/intf_uses.inc b/components/virtualtreeview-unstable/include/intf/win32/intf_uses.inc new file mode 100644 index 000000000..cc11359dc --- /dev/null +++ b/components/virtualtreeview-unstable/include/intf/win32/intf_uses.inc @@ -0,0 +1 @@ +Windows, diff --git a/components/virtualtreeview-unstable/include/intf/win32/olemethods.inc b/components/virtualtreeview-unstable/include/intf/win32/olemethods.inc new file mode 100644 index 000000000..5db24b28e --- /dev/null +++ b/components/virtualtreeview-unstable/include/intf/win32/olemethods.inc @@ -0,0 +1,396 @@ +function TBaseVirtualTree.GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree; + +// Returns the owner/sender of the given data object by means of a special clipboard format +// or nil if the sender is in another process or no virtual tree at all. + +var + Medium: TStgMedium; + Data: PVTReference; + +begin + Result := nil; + if Assigned(DataObject) then + begin + StandardOLEFormat.cfFormat := CF_VTREFERENCE; + if DataObject.GetData(StandardOLEFormat, 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 TBaseVirtualTree.RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; + ForClipboard: Boolean): HResult; + +// Returns a memory expression of all currently selected nodes in the Medium structure. +// Note: The memory requirement of this method might be very high. This depends however on the requested storage format. +// For HGlobal (a global memory block) we need to render first all nodes to local memory and copy this then to +// the global memory in Medium. This is necessary because we have first to determine how much +// memory is needed before we can allocate it. Hence for a short moment we need twice the space as used by the +// nodes alone (plus the amount the nodes need in the tree anyway)! +// With IStream this does not happen. We directly stream out the nodes and pass the constructed stream along. + + //--------------- local function -------------------------------------------- + + procedure WriteNodes(Stream: TStream); + + var + Selection: TNodeArray; + I: Integer; + + begin + if ForClipboard then + Selection := GetSortedCutCopySet(True) + else + Selection := GetSortedSelection(True); + for I := 0 to High(Selection) do + WriteNode(Stream, Selection[I]); + end; + + //--------------- end local function ---------------------------------------- + +var + Data: PCardinal; + ResPointer: Pointer; + ResSize: Integer; + OLEStream: IStream; + VCLStream: TStream; + +begin + FillChar(Medium, SizeOf(Medium), 0); + // We can render the native clipboard format in two different storage media. + if (FormatEtcIn.cfFormat = CF_VIRTUALTREE) and (FormatEtcIn.tymed and (TYMED_HGLOBAL or TYMED_ISTREAM) <> 0) then + begin + 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 + else // Ask application descendants to render self defined formats. + Result := DoRenderOLEData(FormatEtcIn, Medium, ForClipboard); +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 + //raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError)); + raise EStreamError.Create(SCantWriteResourceStreamError); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.ProcessOLEData(Source: TBaseVirtualTree; DataObject: IDataObject; TargetNode: PVirtualNode; + Mode: TVTNodeAttachMode; Optimized: Boolean): Boolean; + +// Recreates the (sub) tree structure serialized into memory and provided by DataObject. The new nodes are attached to +// the passed node or FRoot if TargetNode is nil according to Mode. Optimized can be set to True if the entire operation +// happens within the same process (i.e. sender and receiver of the OLE operation are located in the same process). +// Optimize = True makes only sense if the operation to carry out is a move hence it is also the indication of the +// operation to be done here. Source is the source of the OLE data and only of use (and usually assigned) when +// an OLE operation takes place in the same application. +// Returns True on success, i.e. the CF_VIRTUALTREE format is supported by the data object and the structure could be +// recreated, otherwise False. + +var + Medium: TStgMedium; + Stream: TStream; + Data: Pointer; + Node: PVirtualNode; + Nodes: TNodeArray; + I: Integer; + Res: HRESULT; + ChangeReason: TChangeReason; + +begin + Nodes := nil; + // Check the data format available by the data object. + with StandardOLEFormat do + begin + // Read best format. + cfFormat := CF_VIRTUALTREE; + end; + Result := DataObject.QueryGetData(StandardOLEFormat) = S_OK; + if Result and not (toReadOnly in FOptions.FMiscOptions) then + begin + BeginUpdate; + Result := False; + try + if TargetNode = nil then + TargetNode := FRoot; + if TargetNode = FRoot then + begin + case Mode of + amInsertBefore: + Mode := amAddChildFirst; + amInsertAfter: + Mode := amAddChildLast; + end; + end; + + // Optimized means source is known and in the same process so we can access its pointers, which avoids duplicating + // the data while doing a serialization. Can only be used with cut'n paste and drag'n drop with move effect. + if Optimized then + begin + if tsOLEDragging in Source.FStates then + Nodes := Source.FDragSelection + else + Nodes := Source.GetSortedCutCopySet(True); + + if Mode in [amInsertBefore,amAddChildLast] then + begin + for I := 0 to High(Nodes) do + if not HasAsParent(TargetNode, Nodes[I]) then + Source.MoveTo(Nodes[I], TargetNode, Mode, False); + end + else + begin + for I := High(Nodes) downto 0 do + if not HasAsParent(TargetNode, Nodes[I]) then + Source.MoveTo(Nodes[I], TargetNode, Mode, False); + end; + Result := True; + end + else + begin + if Source = Self then + ChangeReason := crNodeCopied + else + ChangeReason := crNodeAdded; + Res := DataObject.GetData(StandardOLEFormat, Medium); + if Res = S_OK then + begin + case Medium.tymed of + TYMED_ISTREAM, // IStream interface + TYMED_HGLOBAL: // global memory block + begin + Stream := nil; + if Medium.tymed = TYMED_ISTREAM then + Stream := 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)); + Stream := TOLEMemoryStream.Create; + TOLEMemoryStream(Stream).SetPointer(Data, I); + end; + end; + if Assigned(Stream) then + try + while Stream.Position < Stream.Size do + begin + Node := MakeNewNode; + InternalConnectNode(Node, TargetNode, Self, Mode); + InternalAddFromStream(Stream, VTTreeStreamVersion, Node); + // This seems a bit strange because of the callback for granting to add the node + // which actually comes after the node has been added. The reason is that the node must + // contain valid data otherwise I don't see how the application can make a funded decision. + if not DoNodeCopying(Node, TargetNode) then + DeleteNode(Node) + else + DoNodeCopied(Node); + StructureChange(Node, ChangeReason); + + // In order to maintain the same node order when restoring nodes in the case of amInsertAfter + // we have to move the reference node continously. Othwise we would end up with reversed node order. + if Mode = amInsertAfter then + TargetNode := Node; + end; + Result := True; + finally + Stream.Free; + if Medium.tymed = TYMED_HGLOBAL then + GlobalUnlock(Medium.hGlobal); + end; + end; + end; + ReleaseStgMedium(@Medium); + end; + end; + finally + EndUpdate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCustomVirtualStringTree.ContentToClipboard(Format: Word; Source: TVSTTextSourceType): HGLOBAL; + +// This method constructs a shareable memory object filled with string data in the required format. Supported are: +// CF_TEXT - plain ANSI text (Unicode text is converted using the user's current locale) +// CF_UNICODETEXT - plain Unicode text +// CF_CSV - comma separated plain ANSI text +// CF_VRTF + CF_RTFNOOBS - rich text (plain ANSI) +// CF_HTML - HTML text encoded using UTF-8 +// +// Result is the handle to a globally allocated memory block which can directly be used for clipboard and drag'n drop +// transfers. The caller is responsible for freeing the memory. If for some reason the content could not be rendered +// the Result is 0. + + //--------------- local function -------------------------------------------- + + procedure MakeFragment(var HTML: string); + + // Helper routine to build a properly-formatted HTML fragment. + + const + Version = 'Version:1.0'#13#10; + StartHTML = 'StartHTML:'; + EndHTML = 'EndHTML:'; + StartFragment = 'StartFragment:'; + EndFragment = 'EndFragment:'; + DocType = ''; + HTMLIntro = '' + + ''; + HTMLExtro = ''; + NumberLengthAndCR = 10; + + // Let the compiler determine the description length. + DescriptionLength = Length(Version) + Length(StartHTML) + Length(EndHTML) + Length(StartFragment) + + Length(EndFragment) + 4 * NumberLengthAndCR; + + var + Description: string; + StartHTMLIndex, + EndHTMLIndex, + StartFragmentIndex, + EndFragmentIndex: Integer; + + begin + // The HTML clipboard format is defined by using byte positions in the entire block where HTML text and + // fragments start and end. These positions are written in a description. Unfortunately the positions depend on the + // length of the description but the description may change with varying positions. + // To solve this dilemma the offsets are converted into fixed length strings which makes it possible to know + // the description length in advance. + StartHTMLIndex := DescriptionLength; // position 0 after the description + StartFragmentIndex := StartHTMLIndex + Length(DocType) + Length(HTMLIntro); + EndFragmentIndex := StartFragmentIndex + Length(HTML); + EndHTMLIndex := EndFragmentIndex + Length(HTMLExtro); + + Description := Version + + SysUtils.Format('%s%.8d', [StartHTML, StartHTMLIndex]) + #13#10 + + SysUtils.Format('%s%.8d', [EndHTML, EndHTMLIndex]) + #13#10 + + SysUtils.Format('%s%.8d', [StartFragment, StartFragmentIndex]) + #13#10 + + SysUtils.Format('%s%.8d', [EndFragment, EndFragmentIndex]) + #13#10; + HTML := Description + DocType + HTMLIntro + HTML + HTMLExtro; + end; + + //--------------- end local function ---------------------------------------- + +var + Data: Pointer; + DataSize: Cardinal; + S: string; + WS: WideString; + P: Pointer; + +begin + Result := 0; + case Format of + CF_TEXT: + begin + S := ContentToText(Source, #9) + #0; + Data := PChar(S); + DataSize := Length(S); + end; + CF_UNICODETEXT: + begin + WS := ContentToUnicode(Source, #9) + #0; + Data := PWideChar(WS); + DataSize := 2 * Length(WS); + end; + else + if Format = CF_CSV then + S := ContentToText(Source, ListSeparator) + #0 + else + if (Format = CF_VRTF) or (Format = CF_VRTFNOOBJS) then + S := ContentToRTF(Source) + #0 + else + if Format = CF_HTML then + begin + S := ContentToHTML(Source); + // Build a valid HTML clipboard fragment. + MakeFragment(S); + S := S + #0; + end; + Data := PChar(S); + DataSize := Length(S); + end; + + if DataSize > 0 then + begin + Result := GlobalAlloc(GHND or GMEM_SHARE, DataSize); + P := GlobalLock(Result); + Move(Data^, P^, DataSize); + GlobalUnlock(Result); + end; +end; diff --git a/components/virtualtreeview-unstable/virtualtreeview_package.lpk b/components/virtualtreeview-unstable/virtualtreeview_package.lpk index 91d5a63e0..13bc9e031 100644 --- a/components/virtualtreeview-unstable/virtualtreeview_package.lpk +++ b/components/virtualtreeview-unstable/virtualtreeview_package.lpk @@ -8,6 +8,7 @@ +