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

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

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

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

@ -1,18 +1,18 @@
{ This is an automatically generated lazarus resource file } { This is an automatically generated lazarus resource file }
LazarusResources.Add('TMainForm','FORMDATA',[ LazarusResources.Add('TMainForm','FORMDATA',[
'TPF0'#9'TMainForm'#8'MainForm'#4'Left'#2'u'#6'Height'#3'?'#2#3'Top'#3#135#0#5 'TPF0'#9'TMainForm'#8'MainForm'#4'Left'#3'n'#1#6'Height'#3'?'#2#3'Top'#3#215#0
+'Width'#3#22#3#18'HorzScrollBar.Page'#3#21#3#18'VertScrollBar.Page'#3'>'#2#13 +#5'Width'#3#22#3#18'HorzScrollBar.Page'#3#21#3#18'VertScrollBar.Page'#3'>'#2
+'ActiveControl'#7#7'Button1'#7'Caption'#6',Demo for drag''n drop and clipboa' +#13'ActiveControl'#7#7'Button1'#7'Caption'#6',Demo for drag''n drop and clip'
+'rd transfers'#12'Font.CharSet'#7#12'ANSI_CHARSET'#11'Font.Height'#2#244#9'F' +'board transfers'#12'Font.CharSet'#7#12'ANSI_CHARSET'#11'Font.Height'#2#244#9
+'ont.Name'#6#5'Arial'#8'OnCreate'#7#10'FormCreate'#7'Visible'#9#0#6'TLabel'#6 +'Font.Name'#6#5'Arial'#8'OnCreate'#7#10'FormCreate'#7'Visible'#9#0#6'TLabel'
+'Label1'#4'Left'#2#10#6'Height'#2#15#3'Top'#2'`'#5'Width'#3#239#0#7'Caption' +#6'Label1'#4'Left'#2#10#6'Height'#2#15#3'Top'#2'`'#5'Width'#3#239#0#7'Captio'
+#6'1Tree 1 uses OLE when initiating a drag operation.'#5'Color'#7#6'clNone' +'n'#6'1Tree 1 uses OLE when initiating a drag operation.'#5'Color'#7#6'clNon'
+#12'Font.CharSet'#7#12'ANSI_CHARSET'#11'Font.Height'#2#245#9'Font.Name'#6#5 +'e'#12'Font.CharSet'#7#12'ANSI_CHARSET'#11'Font.Height'#2#245#9'Font.Name'#6
+'Arial'#11'ParentColor'#8#0#0#6'TLabel'#6'Label2'#4'Left'#3'h'#1#6'Height'#2 +#5'Arial'#11'ParentColor'#8#0#0#6'TLabel'#6'Label2'#4'Left'#3'h'#1#6'Height'
+'!'#3'Top'#2'P'#5'Width'#3'Q'#1#8'AutoSize'#8#7'Caption'#6#137'Tree 2 uses V' +#2'!'#3'Top'#2'P'#5'Width'#3'Q'#1#8'AutoSize'#8#7'Caption'#6#137'Tree 2 uses'
+'CL when initiating a drag operation. It also uses manual drag mode. Only ma' +' VCL when initiating a drag operation. It also uses manual drag mode. Only '
+'rked lines are allowed to start a drag operation.'#5'Color'#7#6'clNone'#12 +'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' +'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 +'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 +'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' +'DragAllowed'#7#16'Tree2DragAllowed'#10'OnDragOver'#7#12'TreeDragOver'#10'On'
+'DragDrop'#7#12'TreeDragDrop'#9'OnGetText'#7#12'Tree1GetText'#10'OnInitNode' +'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' +#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' +'VirtualStringTree'#5'Tree1'#4'Left'#2#8#6'Height'#3#180#0#3'Top'#2't'#5'Wid'
+'dth'#3'J'#1#24'ClipboardFormats.Strings'#1#6#3'CSV'#6#11'HTML Format'#6#10 +'th'#3'J'#1#24'ClipboardFormats.Strings'#1#6#3'CSV'#6#11'HTML Format'#6#10'P'
+'Plain text'#6#16'Rich Text Format'#6' Rich Text Format Without Objects'#6#12 +'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' +'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 +'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' +'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 uses
Windows, LCLIntf, Messages, ActiveX, SysUtils, Forms, Dialogs, Graphics, Windows, LCLIntf, Messages, ActiveX, SysUtils, Forms, Dialogs, Graphics,
VirtualTrees, ActnList, ComCtrls, ExtCtrls, StdCtrls, Controls, Classes, Buttons, VirtualTrees, ActnList, ComCtrls, ExtCtrls, StdCtrls, Controls, Classes, Buttons,
ImgList, LResources, vtLogger,ipcchannel; ImgList, LResources, vtLogger,ipcchannel, virtualdragmanager;
type type
TMainForm = class(TForm) TMainForm = class(TForm)
@ -91,6 +91,8 @@ type
procedure ReleaseStgMedium(_para1:LPSTGMEDIUM);stdcall;external 'ole32.dll' name 'ReleaseStgMedium'; 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); procedure TMainForm.Button1Click(Sender: TObject);
@ -208,10 +210,10 @@ var
begin begin
Logger.Channels.Add(TIPCChannel.Create); Logger.Channels.Add(TIPCChannel.Create);
Logger.Clear; Logger.Clear;
Logger.ActiveClasses:=[lcDrag,lcPaintDetails,lcPaintBitmap]; Logger.ActiveClasses:=[lcDrag];//,lcPaintDetails,lcPaintBitmap];
//Logger.Enabled:=False; //Logger.Enabled:=False;
Tree1.NodeDataSize := SizeOf(TNodeData); Tree1.NodeDataSize := SizeOf(TNodeData);
Tree1.RootNodeCount := 10; Tree1.RootNodeCount := 30;
Tree2.NodeDataSize := SizeOf(TNodeData); Tree2.NodeDataSize := SizeOf(TNodeData);
Tree2.RootNodeCount := 30; Tree2.RootNodeCount := 30;

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

@ -34,7 +34,7 @@
<PackageName Value="LCL"/> <PackageName Value="LCL"/>
</Item2> </Item2>
</RequiredPackages> </RequiredPackages>
<Units Count="2"> <Units Count="3">
<Unit0> <Unit0>
<Filename Value="ole.lpr"/> <Filename Value="ole.lpr"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
@ -48,6 +48,11 @@
<ResourceFilename Value="Main.lrs"/> <ResourceFilename Value="Main.lrs"/>
<UnitName Value="Main"/> <UnitName Value="Main"/>
</Unit1> </Unit1>
<Unit2>
<Filename Value="..\..\units\win32\virtualdragmanager.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="virtualdragmanager"/>
</Unit2>
</Units> </Units>
</ProjectOptions> </ProjectOptions>
<CompilerOptions> <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'; 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"/> <Version Value="5"/>
<PathDelim Value="\"/> <PathDelim Value="\"/>
<SearchPaths> <SearchPaths>
<OtherUnitFiles Value="units\$(LCLWidgetType)\"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths> </SearchPaths>
<CodeGeneration> <CodeGeneration>