pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

* Moved OLE code to include files

Browse Source 
* Cleaned defines

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@263 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
blikblum
2007-09-09 13:27:06 +00:00
parent e1a93f2c6a
commit 4c0ee502c7
6 changed files with 1125 additions and 1157 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
components/virtualtreeview-unstable/VTConfig.inc
View File

@@ -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}

1157
components/virtualtreeview-unstable/VirtualTrees.pas
View File

File diff suppressed because it is too large Load Diff

722
components/virtualtreeview-unstable/include/intf/win32/dragmanager.inc Normal file
View File

@@ -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;

1
components/virtualtreeview-unstable/include/intf/win32/intf_uses.inc Normal file
View File

@@ -0,0 +1 @@
Windows,

396
components/virtualtreeview-unstable/include/intf/win32/olemethods.inc Normal file
View File

@@ -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 = '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">';
HTMLIntro = '<html><head><META http-equiv=Content-Type content="text/html; charset=utf-8">' +
'</head><body><!--StartFragment-->';
HTMLExtro = '<!--EndFragment--></body></html>';
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;

1
components/virtualtreeview-unstable/virtualtreeview_package.lpk
View File

@@ -8,6 +8,7 @@
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="include\intf\$(LCLWidgetType)\"/>
<OtherUnitFiles Value="units\$(LCLWidgetType)\"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>