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

Started to isolate OLE functions

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@118 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
blikblum
2007-03-05 23:28:47 +00:00
parent 93fd07caa5
commit 553c1325ac
9 changed files with 855 additions and 47 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@ -34,3 +34,4 @@
{$define EnableHeader}
{$define EnableTimer}
{.$define EnableAccessible}
{$define UseExternalDragManager}

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

@ -103,8 +103,8 @@ interface
{$HPPEMIT '#include <oleidl.h>'} // Necessary for BCB 6 SP 2.
uses
{$ifdef NeedWindows}
{$ifdef UseExternalDragManager}
virtualdragmanager,
{$endif}
Windows, DelphiCompat, vtlogger, LCLType, LResources, LCLIntf, LMessages, Types,
SysUtils, Classes, Graphics, Controls, Forms, ImgList, StdCtrls, Menus, Printers,
@ -206,7 +206,7 @@ const
CFSTR_RTF = 'Rich Text Format';
CFSTR_RTFNOOBJS = 'Rich Text Format Without Objects';
CFSTR_CSV = 'CSV';
{$ifndef UseExternalDragManager}
// Drag image helpers for Windows 2000 and up.
IID_IDropTargetHelper: TGUID = (D1: $4657278B; D2: $411B; D3: $11D2; D4: ($83, $9A, $00, $C0, $4F, $D9, $18, $D0));
IID_IDragSourceHelper: TGUID = (D1: $DE5BF786; D2: $477A; D3: $11D2; D4: ($83, $9D, $00, $C0, $4F, $D9, $18, $D0));
@ -216,7 +216,7 @@ const
SID_IDropTargetHelper = '{4657278B-411B-11D2-839A-00C04FD918D0}';
SID_IDragSourceHelper = '{DE5BF786-477A-11D2-839D-00C04FD918D0}';
SID_IDropTarget = '{00000122-0000-0000-C000-000000000046}';
{$endif}
// Help identifiers for exceptions. Application developers are responsible to link them with actual help topics.
hcTFEditLinkIsNil = 2000;
hcTFWrongMoveError = 2001;
@ -677,19 +677,19 @@ type
sdDown
);
{$ifdef EnableOLE}
{$ifndef UseExternalDragManager}
// OLE drag'n drop support
TFormatEtcArray = array of TFormatEtc;
TFormatArray = array of Word;
// IDataObject.SetData support
TInternalStgMedium = packed record
Format: TClipFormat;
Medium: TStgMedium;
end;
TInternalStgMediumArray = array of TInternalStgMedium;
{$endif}
TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc)
private
FTree: TBaseVirtualTree;
@ -704,11 +704,12 @@ type
function Skip(celt: LongWord): HResult; stdcall;
end;
{$ifndef UseExternalDragManager}
// ----- OLE drag'n drop handling
{ 01.05.2006 Jim - Problem with BDS2006 C++ compiler and ambiguous defines}
{$EXTERNALSYM IDropTargetHelper}
IDropTargetHelper = interface(IUnknown)
[SID_IDropTargetHelper]
function DragEnter(hwndTarget: HWND; pDataObject: IDataObject; var ppt: TPoint; dwEffect: Integer): HRESULT; stdcall;
@ -732,6 +733,7 @@ type
function InitializeFromWindow(Window: HWND; var ppt: TPoint; pDataObject: IDataObject): HRESULT; stdcall;
end;
IVTDragManager = interface(IUnknown)
['{C4B25559-14DA-446B-8901-0C879000EB16}']
procedure ForceDragLeave; stdcall;
@ -813,8 +815,7 @@ type
function GiveFeedback(Effect: Integer): HResult; stdcall;
function QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult; stdcall;
end;
{$endif}//enableOLE
{$endif} //UseExternalDragManager
PVTHintData = ^TVTHintData;
TVTHintData = record
@ -884,6 +885,8 @@ type
disPrepared, // Drag image class is prepared.
disSystemSupport // Running on Windows 2000 or higher. System supports drag images natively.
);
{$ifdef EnableOLE}
// Class to manage header and tree drag image during a drag'n drop operation.
TVTDragImage = class
@ -927,7 +930,7 @@ type
property Transparency: TVTTransparency read FTransparency write FTransparency default 128;
property Visible: Boolean read GetVisible;
end;
{$endif}
// tree columns implementation
TVirtualTreeColumns = class;
TVTHeader = class;
@ -2273,6 +2276,8 @@ TBaseVirtualTree = class(TCustomControl)
function FindNodeInSelection(P: PVirtualNode; var Index: Integer; LowBound, HighBound: Integer): Boolean; virtual;
procedure FinishChunkHeader(Stream: TStream; StartPos, EndPos: Integer); virtual;
procedure FontChanged(AFont: TObject); virtual;
//lcl
procedure FreeDragManager;
function GetBorderDimensions: TSize; virtual;
function GetCheckImage(Node: PVirtualNode): Integer; virtual;
class function GetCheckImageListFor(Kind: TCheckImageKind): TCustomImageList; virtual;
@ -5822,6 +5827,8 @@ begin
Result := S_FALSE;
end;
{$ifndef UseExternalDragManager}
//----------------- TVTDataObject --------------------------------------------------------------------------------------
constructor TVTDataObject.Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean);
@ -5938,7 +5945,6 @@ var
NewData: PChar;
begin
{$ifdef NeedWindows}
Size := GlobalSize(HGlobal);
Result := GlobalAlloc(GPTR, Size);
Data := GlobalLock(hGlobal);
@ -5952,7 +5958,6 @@ begin
finally
GlobalUnLock(hGlobal);
end;
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
@ -6131,7 +6136,6 @@ var
Data: PVTReference;
begin
{$ifdef NeedWindows}
// The tree reference format is always supported and returned from here.
if FormatEtcIn.cfFormat = CF_VTREFERENCE then
begin
@ -6173,7 +6177,6 @@ begin
Result := E_FAIL;
end;
end;
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
@ -6355,7 +6358,6 @@ function TVTDragManager.DragEnter(const DataObject: IDataObject; KeyState: LongW
var Effect: LongWord): HResult;
begin
{$ifdef NeedWindows}
FDataObject := DataObject;
FIsDropTarget := True;
@ -6369,7 +6371,6 @@ begin
FDragSource := FOwner.GetTreeFromDataObject(DataObject);
Result := FOwner.DragEnter(KeyState, Pt, Effect);
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
@ -6455,7 +6456,7 @@ begin
else
Result := S_OK;
end;
{$endif} //UseExternalDragManager
{$endif} //EnableOLE
//----------------- TVirtualTreeHintWindow -----------------------------------------------------------------------------
@ -7188,7 +7189,6 @@ var
RClip: TRect; // ScrollDC of the existent background
begin
{$ifdef NeedWindows}
// Determine distances to move the drag image. Take care for restrictions.
case FRestriction of
dmrHorizontalOnly:
@ -7303,7 +7303,6 @@ begin
FLastPosition.X := P.X;
FLastPosition.Y := P.Y;
end;
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
@ -7377,7 +7376,6 @@ var
DragInfo: TSHDragImage;
begin
{$ifdef NeedWindows}
Width := DragImage.Width;
Height := DragImage.Height;
@ -7438,7 +7436,6 @@ begin
// Initially the drag image is hidden and will be shown during the immediately following DragEnter event.
FStates := FStates + [disInDrag, disHidden, disPrepared];
end;
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
@ -18765,6 +18762,7 @@ var
begin
Logger.EnterMethod([lcDrag],'DoDragging');
Logger.SendCallStack([lcDrag],'Stack');
DataObject := nil;
// Dragging is dragging, nothing else.
DoCancelEdit;
@ -18848,7 +18846,7 @@ begin
not (vsExpanded in FDropTargetNode.States) then
begin
if Assigned(FDragManager) then
SourceTree := DragManager.DragSource
SourceTree := TBaseVirtualTree(DragManager.DragSource)
else
SourceTree := nil;
@ -19703,6 +19701,8 @@ procedure TBaseVirtualTree.DoStartDrag(var DragObject: TDragObject);
begin
Logger.EnterMethod([lcDrag],'DoStartDrag');
Logger.SendCallStack([lcDrag],'Stack');
inherited;
// Check if the application created an own drag object. This is needed to pass the correct source in
@ -20117,7 +20117,7 @@ begin
// and can show it even if the source is not the target tree.
// This is only necessary if we cannot use the drag image helper interfaces.
if not DragManager.DropTargetHelperSupported and Assigned(DragManager.DragSource) then
DragManager.DragSource.FDragImage.ShowDragImage;
TBaseVirtualTree(DragManager.DragSource).FDragImage.ShowDragImage;
Result := NOERROR;
except
Result := E_UNEXPECTED;
@ -20162,7 +20162,7 @@ begin
StopTimer(ExpandTimer);
if not DragManager.DropTargetHelperSupported and Assigned(DragManager.DragSource) then
DragManager.DragSource.FDragImage.HideDragImage;
TBaseVirtualTree(DragManager.DragSource).FDragImage.HideDragImage;
if Assigned(FDropTargetNode) then
begin
@ -20502,6 +20502,13 @@ begin
FOldFontChange(AFont);
end;
procedure TBaseVirtualTree.FreeDragManager;
begin
//lcl
Pointer(FDragManager) := nil;
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.GetBorderDimensions: TSize;
@ -24194,6 +24201,7 @@ procedure TBaseVirtualTree.BeginDrag(Immediate: Boolean; Threshold: Integer);
// Reintroduced method to allow to start OLE drag'n drop as well as VCL drag'n drop.
begin
Logger.EnterMethod([lcDrag],'BeginDrag');
if FDragType = dtVCL then
begin
DoStateChange([tsVCLDragPending]);
@ -24212,6 +24220,7 @@ begin
else
DoStateChange([tsOLEDragPending]);
end;
Logger.ExitMethod([lcDrag],'BeginDrag');
end;
//----------------------------------------------------------------------------------------------------------------------

6
components/virtualtreeview-unstable/demos/ole/Main.lfm
View File

@ -1,7 +1,7 @@
object MainForm: TMainForm
Left = 117
Left = 366
Height = 575
Top = 135
Top = 215
Width = 790
HorzScrollBar.Page = 789
VertScrollBar.Page = 574
@ -126,7 +126,7 @@ object MainForm: TMainForm
Columns = <>
end
object Tree1: TVirtualStringTree
Left = 10
Left = 8
Height = 180
Top = 116
Width = 330

30
components/virtualtreeview-unstable/demos/ole/Main.lrs
View File

@ -1,18 +1,18 @@
{ This is an automatically generated lazarus resource file }
LazarusResources.Add('TMainForm','FORMDATA',[
'TPF0'#9'TMainForm'#8'MainForm'#4'Left'#2'u'#6'Height'#3'?'#2#3'Top'#3#135#0#5
+'Width'#3#22#3#18'HorzScrollBar.Page'#3#21#3#18'VertScrollBar.Page'#3'>'#2#13
+'ActiveControl'#7#7'Button1'#7'Caption'#6',Demo for drag''n drop and clipboa'
+'rd transfers'#12'Font.CharSet'#7#12'ANSI_CHARSET'#11'Font.Height'#2#244#9'F'
+'ont.Name'#6#5'Arial'#8'OnCreate'#7#10'FormCreate'#7'Visible'#9#0#6'TLabel'#6
+'Label1'#4'Left'#2#10#6'Height'#2#15#3'Top'#2'`'#5'Width'#3#239#0#7'Caption'
+#6'1Tree 1 uses OLE when initiating a drag operation.'#5'Color'#7#6'clNone'
+#12'Font.CharSet'#7#12'ANSI_CHARSET'#11'Font.Height'#2#245#9'Font.Name'#6#5
+'Arial'#11'ParentColor'#8#0#0#6'TLabel'#6'Label2'#4'Left'#3'h'#1#6'Height'#2
+'!'#3'Top'#2'P'#5'Width'#3'Q'#1#8'AutoSize'#8#7'Caption'#6#137'Tree 2 uses V'
+'CL when initiating a drag operation. It also uses manual drag mode. Only ma'
+'rked lines are allowed to start a drag operation.'#5'Color'#7#6'clNone'#12
'TPF0'#9'TMainForm'#8'MainForm'#4'Left'#3'n'#1#6'Height'#3'?'#2#3'Top'#3#215#0
+#5'Width'#3#22#3#18'HorzScrollBar.Page'#3#21#3#18'VertScrollBar.Page'#3'>'#2
+#13'ActiveControl'#7#7'Button1'#7'Caption'#6',Demo for drag''n drop and clip'
+'board transfers'#12'Font.CharSet'#7#12'ANSI_CHARSET'#11'Font.Height'#2#244#9
+'Font.Name'#6#5'Arial'#8'OnCreate'#7#10'FormCreate'#7'Visible'#9#0#6'TLabel'
+#6'Label1'#4'Left'#2#10#6'Height'#2#15#3'Top'#2'`'#5'Width'#3#239#0#7'Captio'
+'n'#6'1Tree 1 uses OLE when initiating a drag operation.'#5'Color'#7#6'clNon'
+'e'#12'Font.CharSet'#7#12'ANSI_CHARSET'#11'Font.Height'#2#245#9'Font.Name'#6
+#5'Arial'#11'ParentColor'#8#0#0#6'TLabel'#6'Label2'#4'Left'#3'h'#1#6'Height'
+#2'!'#3'Top'#2'P'#5'Width'#3'Q'#1#8'AutoSize'#8#7'Caption'#6#137'Tree 2 uses'
+' VCL when initiating a drag operation. It also uses manual drag mode. Only '
+'marked lines are allowed to start a drag operation.'#5'Color'#7#6'clNone'#12
+'Font.CharSet'#7#12'ANSI_CHARSET'#11'Font.Height'#2#245#9'Font.Name'#6#5'Ari'
+'al'#11'ParentColor'#8#8'WordWrap'#9#0#0#6'TPanel'#6'Panel3'#6'Height'#2'E'#5
+'Width'#3#22#3#5'Align'#7#5'alTop'#5'Color'#7#7'clWhite'#11'ParentColor'#8#8
@ -46,9 +46,9 @@ LazarusResources.Add('TMainForm','FORMDATA',[
+'DragAllowed'#7#16'Tree2DragAllowed'#10'OnDragOver'#7#12'TreeDragOver'#10'On'
+'DragDrop'#7#12'TreeDragDrop'#9'OnGetText'#7#12'Tree1GetText'#10'OnInitNode'
+#7#12'TreeInitNode'#9'OnNewText'#7#12'Tree1NewText'#7'Columns'#14#0#0#0#18'T'
+'VirtualStringTree'#5'Tree1'#4'Left'#2#10#6'Height'#3#180#0#3'Top'#2't'#5'Wi'
+'dth'#3'J'#1#24'ClipboardFormats.Strings'#1#6#3'CSV'#6#11'HTML Format'#6#10
+'Plain text'#6#16'Rich Text Format'#6' Rich Text Format Without Objects'#6#12
+'VirtualStringTree'#5'Tree1'#4'Left'#2#8#6'Height'#3#180#0#3'Top'#2't'#5'Wid'
+'th'#3'J'#1#24'ClipboardFormats.Strings'#1#6#3'CSV'#6#11'HTML Format'#6#10'P'
+'lain text'#6#16'Rich Text Format'#6' Rich Text Format Without Objects'#6#12
+'Unicode text'#0#18'Colors.BorderColor'#7#12'clWindowText'#15'Colors.HotColo'
+'r'#7#7'clBlack'#17'DefaultNodeHeight'#2#24#8'DragMode'#7#11'dmAutomatic'#9
+'DragWidth'#3'^'#1#9'EditDelay'#3#244#1#12'Font.CharSet'#7#12'ANSI_CHARSET'

8
components/virtualtreeview-unstable/demos/ole/Main.pas
View File

@ -11,7 +11,7 @@ interface
uses
Windows, LCLIntf, Messages, ActiveX, SysUtils, Forms, Dialogs, Graphics,
VirtualTrees, ActnList, ComCtrls, ExtCtrls, StdCtrls, Controls, Classes, Buttons,
ImgList, LResources, vtLogger,ipcchannel;
ImgList, LResources, vtLogger,ipcchannel, virtualdragmanager;
type
TMainForm = class(TForm)
@ -91,6 +91,8 @@ type
procedure ReleaseStgMedium(_para1:LPSTGMEDIUM);stdcall;external 'ole32.dll' name 'ReleaseStgMedium';
function OleGetClipboard(out ppDataObj:IDataObject):WINOLEAPI;stdcall;external 'ole32.dll' name 'OleGetClipboard';
//----------------------------------------------------------------------------------------------------------------------
procedure TMainForm.Button1Click(Sender: TObject);
@ -208,10 +210,10 @@ var
begin
Logger.Channels.Add(TIPCChannel.Create);
Logger.Clear;
Logger.ActiveClasses:=[lcDrag,lcPaintDetails,lcPaintBitmap];
Logger.ActiveClasses:=[lcDrag];//,lcPaintDetails,lcPaintBitmap];
//Logger.Enabled:=False;
Tree1.NodeDataSize := SizeOf(TNodeData);
Tree1.RootNodeCount := 10;
Tree1.RootNodeCount := 30;
Tree2.NodeDataSize := SizeOf(TNodeData);
Tree2.RootNodeCount := 30;

7
components/virtualtreeview-unstable/demos/ole/ole.lpi
View File

@ -34,7 +34,7 @@
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Units Count="3">
<Unit0>
<Filename Value="ole.lpr"/>
<IsPartOfProject Value="True"/>
@ -48,6 +48,11 @@
<ResourceFilename Value="Main.lrs"/>
<UnitName Value="Main"/>
</Unit1>
<Unit2>
<Filename Value="..\..\units\win32\virtualdragmanager.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="virtualdragmanager"/>
</Unit2>
</Units>
</ProjectOptions>
<CompilerOptions>

8
components/virtualtreeview-unstable/lclfunctions.inc
View File

@ -266,4 +266,12 @@ procedure OleUninitialize;stdcall;external 'ole32.dll' name 'OleUninitialize';
procedure ReleaseStgMedium(_para1:LPSTGMEDIUM);stdcall;external 'ole32.dll' name 'ReleaseStgMedium';
function OleSetClipboard(pDataObj:IDataObject):WINOLEAPI;stdcall;external 'ole32.dll' name 'OleSetClipboard';
function OleGetClipboard(out ppDataObj:IDataObject):WINOLEAPI;stdcall;external 'ole32.dll' name 'OleGetClipboard';
function OleFlushClipboard:WINOLEAPI;stdcall;external 'ole32.dll' name 'OleFlushClipboard';
function OleIsCurrentClipboard(pDataObj:IDataObject):WINOLEAPI;stdcall;external 'ole32.dll' name 'OleIsCurrentClipboard';

782
components/virtualtreeview-unstable/units/win32/virtualdragmanager.pas Normal file
View File

@ -0,0 +1,782 @@
unit virtualdragmanager;
{$mode delphi}
interface
uses
Windows, ActiveX, Classes, SysUtils;
const
// Drag image helpers for Windows 2000 and up.
IID_IDropTargetHelper: TGUID = (D1: $4657278B; D2: $411B; D3: $11D2; D4: ($83, $9A, $00, $C0, $4F, $D9, $18, $D0));
IID_IDragSourceHelper: TGUID = (D1: $DE5BF786; D2: $477A; D3: $11D2; D4: ($83, $9D, $00, $C0, $4F, $D9, $18, $D0));
IID_IDropTarget: TGUID = (D1: $00000122; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46));
CLSID_DragDropHelper: TGUID = (D1: $4657278A; D2: $411B; D3: $11D2; D4: ($83, $9A, $00, $C0, $4F, $D9, $18, $D0));
SID_IDropTargetHelper = '{4657278B-411B-11D2-839A-00C04FD918D0}';
SID_IDragSourceHelper = '{DE5BF786-477A-11D2-839D-00C04FD918D0}';
SID_IDropTarget = '{00000122-0000-0000-C000-000000000046}';
type
// OLE drag'n drop support
TFormatEtcArray = array of TFormatEtc;
TFormatArray = array of Word;
// IDataObject.SetData support
TInternalStgMedium = packed record
Format: TClipFormat;
Medium: TStgMedium;
end;
TInternalStgMediumArray = array of TInternalStgMedium;
IDropTargetHelper = interface(IUnknown)
[SID_IDropTargetHelper]
function DragEnter(hwndTarget: HWND; pDataObject: IDataObject; var ppt: TPoint; dwEffect: Integer): HRESULT; stdcall;
function DragLeave: HRESULT; stdcall;
function DragOver(var ppt: TPoint; dwEffect: Integer): HRESULT; stdcall;
function Drop(pDataObject: IDataObject; var ppt: TPoint; dwEffect: Integer): HRESULT; stdcall;
function Show(fShow: Boolean): HRESULT; stdcall;
end;
PSHDragImage = ^TSHDragImage;
TSHDragImage = packed record
sizeDragImage: TSize;
ptOffset: TPoint;
hbmpDragImage: HBITMAP;
ColorRef: TColorRef;
end;
IDragSourceHelper = interface(IUnknown)
[SID_IDragSourceHelper]
function InitializeFromBitmap(var SHDragImage: TSHDragImage; pDataObject: IDataObject): HRESULT; stdcall;
function InitializeFromWindow(Window: HWND; var ppt: TPoint; pDataObject: IDataObject): HRESULT; stdcall;
end;
IVTDragManager = interface(IUnknown)
['{C4B25559-14DA-446B-8901-0C879000EB16}']
procedure ForceDragLeave; stdcall;
function GetDataObject: IDataObject; stdcall;
function GetDragSource: TObject; stdcall;
function GetDropTargetHelperSupported: Boolean; stdcall;
function GetIsDropTarget: Boolean; stdcall;
property DataObject: IDataObject read GetDataObject;
property DragSource: TObject read GetDragSource;
property DropTargetHelperSupported: Boolean read GetDropTargetHelperSupported;
property IsDropTarget: Boolean read GetIsDropTarget;
end;
// This data object is used in two different places. One is for clipboard operations and the other while dragging.
TVTDataObject = class(TInterfacedObject, IDataObject)
private
//FOwner: TBaseVirtualTree; // The tree which provides clipboard or drag data.
FOwner: TObject; // The tree which provides clipboard or drag data.
FForClipboard: Boolean; // Determines which data to render with GetData.
FFormatEtcArray: TFormatEtcArray;
FInternalStgMediumArray: TInternalStgMediumArray; // The available formats in the DataObject
FAdviseHolder: IDataAdviseHolder; // Reference to an OLE supplied implementation for advising.
protected
function CanonicalIUnknown(TestUnknown: IUnknown): IUnknown;
function EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean;
function FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer;
function FindInternalStgMedium(Format: TClipFormat): PStgMedium;
function HGlobalClone(HGlobal: THandle): THandle;
function RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium; var OLEResult: HResult): Boolean;
function StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium;
CopyInMedium: Boolean; DataObject: IDataObject): HRESULT;
property ForClipboard: Boolean read FForClipboard;
property FormatEtcArray: TFormatEtcArray read FFormatEtcArray write FFormatEtcArray;
property InternalStgMediumArray: TInternalStgMediumArray read FInternalStgMediumArray write FInternalStgMediumArray;
property Owner: TObject read FOwner;
public
constructor Create(AOwner: TObject; ForClipboard: Boolean); virtual;
destructor Destroy; override;
function DAdvise(const FormatEtc: TFormatEtc; advf: DWord; const advSink: IAdviseSink; out dwConnection: DWord):
HResult; virtual; stdcall;
function DUnadvise(dwConnection: DWord): HResult; virtual; stdcall;
Function EnumDAvise(Out enumAdvise : IEnumStatData):HResult;virtual;StdCall;
function EnumFormatEtc(Direction: DWord; out EnumFormatEtc: IEnumFormatEtc): HResult; virtual; stdcall;
Function GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; virtual; STDCALl;
function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall;
function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall;
function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall;
function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall;
end;
// TVTDragManager is a class to manage drag and drop in a Virtual Treeview.
TVTDragManager = class(TInterfacedObject, IVTDragManager, IDropSource, IDropTarget)
private
FOwner, // The tree which is responsible for drag management.
FDragSource: TObject; // Reference to the source tree if the source was a VT, might be different than
// the owner tree.
FIsDropTarget: Boolean; // True if the owner is currently the drop target.
FDataObject: IDataObject; // A reference to the data object passed in by DragEnter (only used when the owner
// tree is the current drop target).
FDropTargetHelper: IDropTargetHelper; // Win2k > Drag image support
FFullDragging: BOOL; // True, if full dragging is currently enabled in the system.
function GetDataObject: IDataObject; stdcall;
function GetDragSource: TObject; stdcall;
function GetDropTargetHelperSupported: Boolean; stdcall;
function GetIsDropTarget: Boolean; stdcall;
public
constructor Create(AOwner: TObject); virtual;
destructor Destroy; override;
function DragEnter(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint;
var Effect: LongWord): HResult; stdcall;
function DragLeave: HResult; stdcall;
function DragOver(KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult; stdcall;
function Drop(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult; stdcall;
procedure ForceDragLeave; stdcall;
function GiveFeedback(Effect: Integer): HResult; stdcall;
function QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult; stdcall;
end;
implementation
uses
VirtualTrees, Controls;
type
TVirtualTreeAccess = class (TBaseVirtualTree)
end;
//----------------- TVTDataObject --------------------------------------------------------------------------------------
constructor TVTDataObject.Create(AOwner: TObject; ForClipboard: Boolean);
begin
inherited Create;
FOwner := AOwner;
FForClipboard := ForClipboard;
TVirtualTreeAccess(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 TVirtualTreeAccess(FOwner).TreeStates) then
TVirtualTreeAccess(FOwner).CancelCutOrCopy;
// Release any internal clipboard formats
for I := 0 to High(FormatEtcArray) do
begin
StgMedium := FindInternalStgMedium(FormatEtcArray[I].cfFormat);
if Assigned(StgMedium) then
ReleaseStgMedium(StgMedium);
end;
FormatEtcArray := nil;
inherited;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.CanonicalIUnknown(TestUnknown: IUnknown): IUnknown;
// Uses COM object identity: An explicit call to the IUnknown::QueryInterface method, requesting the IUnknown
// interface, will always return the same pointer.
begin
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(TVirtualTreeAccess(FOwner), FormatEtcArray);
EnumFormatEtc := NewList as IEnumFormatEtc;
Result := S_OK;
end
else
EnumFormatEtc := nil;
if EnumFormatEtc = nil then
Result := OLE_S_USEREG;
end;
//----------------------------------------------------------------------------------------------------------------------
Function TVTDataObject.GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult;
begin
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 TVirtualTreeAccess(FOwner).TreeStates then
Result := E_FAIL
else
begin
Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference));
Data := GlobalLock(Medium.hGlobal);
Data.Process := GetCurrentProcessID;
Data.Tree := TBaseVirtualTree(FOwner);
GlobalUnlock(Medium.hGlobal);
Medium.tymed := TYMED_HGLOBAL;
Medium.PunkForRelease := nil;
Result := S_OK;
end;
end
else
begin
try
// See if we accept this type and if not get the correct return value.
Result := QueryGetData(FormatEtcIn);
if Result = S_OK then
begin
for I := 0 to High(FormatEtcArray) do
begin
if EqualFormatEtc(FormatEtcIn, FormatEtcArray[I]) then
begin
if not RenderInternalOLEData(FormatEtcIn, Medium, Result) then
Result := TVirtualTreeAccess(FOwner).RenderOLEData(FormatEtcIn, Medium, FForClipboard);
Break;
end;
end
end
except
FillChar(Medium, SizeOf(Medium), #0);
Result := E_FAIL;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult;
begin
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; var Medium: TStgMedium; DoRelease: BOOL): HResult;
// Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement
// IDropSourceHelper and allows to set a special format for optimized moves during a shell transfer.
var
Index: Integer;
LocalStgMedium: PStgMedium;
begin
// See if we already have a format of that type available.
Index := FindFormatEtc(FormatEtc, FormatEtcArray);
if Index > - 1 then
begin
// Just use the TFormatEct in the array after releasing the data.
LocalStgMedium := FindInternalStgMedium(FormatEtcArray[Index].cfFormat);
if Assigned(LocalStgMedium) then
begin
ReleaseStgMedium(LocalStgMedium);
FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0);
end;
end
else
begin
// It is a new format so create a new TFormatCollectionItem, copy the
// FormatEtc parameter into the new object and and put it in the list.
SetLength(FFormatEtcArray, Length(FormatEtcArray) + 1);
FormatEtcArray[High(FormatEtcArray)] := FormatEtc;
// Create a new InternalStgMedium and initialize it and associate it with the format.
SetLength(FInternalStgMediumArray, Length(InternalStgMediumArray) + 1);
InternalStgMediumArray[High(InternalStgMediumArray)].Format := FormatEtc.cfFormat;
LocalStgMedium := @InternalStgMediumArray[High(InternalStgMediumArray)].Medium;
FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0);
end;
if DoRelease then
begin
// We are simply being given the data and we take control of it.
LocalStgMedium^ := Medium;
Result := S_OK
end
else
begin
// We need to reference count or copy the data and keep our own references to it.
Result := StgMediumIncRef(Medium, LocalStgMedium^, True, Self as IDataObject);
// Can get a circular reference if the client calls GetData then calls SetData with the same StgMedium.
// Because the unkForRelease for the IDataObject can be marshalled it is necessary to get pointers that
// can be correctly compared. See the IDragSourceHelper article by Raymond Chen at MSDN.
if Assigned(LocalStgMedium.PunkForRelease) then
begin
if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.PunkForRelease)) then
IUnknown(LocalStgMedium.PunkForRelease) := nil; // release the interface
end;
end;
// Tell all registered advice sinks about the data change.
if Assigned(FAdviseHolder) then
FAdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0);
end;
//----------------- TVTDragManager -------------------------------------------------------------------------------------
constructor TVTDragManager.Create(AOwner: TObject);
begin
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.
TVirtualTreeAccess(FOwner).FreeDragManager;
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 := TVirtualTreeAccess(FOwner).DoCreateDataObject;
if Result = nil then
Result := TVTDataObject.Create(FOwner, False) as IDataObject;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetDragSource: TObject;
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(TBaseVirtualTree(FOwner).Handle, DataObject, Pt, Effect);
FDragSource := TVirtualTreeAccess(FOwner).GetTreeFromDataObject(DataObject);
Result := TVirtualTreeAccess(FOwner).DragEnter(KeyState, Pt, Effect);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.DragLeave: HResult;
begin
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragLeave;
TVirtualTreeAccess(FOwner).DragLeave;
FIsDropTarget := False;
FDragSource := nil;
FDataObject := nil;
Result := NOERROR;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.DragOver(KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult;
begin
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragOver(Pt, Effect);
Result := TVirtualTreeAccess(FOwner).DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.Drop(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint;
var Effect: LongWord): HResult;
begin
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.Drop(DataObject, Pt, Effect);
Result := TVirtualTreeAccess(FOwner).DragDrop(DataObject, KeyState, Pt, Effect);
FIsDropTarget := False;
FDataObject := nil;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTDragManager.ForceDragLeave;
// Some drop targets, e.g. Internet Explorer leave a drag image on screen instead removing it when they receive
// a drop action. This method calls the drop target helper's DragLeave method to ensure it removes the drag image from
// screen. Unfortunately, sometimes not even this does help (e.g. when dragging text from VT to a text field in IE).
begin
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;
end.

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

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