1135 lines
39 KiB
ObjectPascal
1135 lines
39 KiB
ObjectPascal
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}';
|
|
|
|
//Bridge to ActiveX constants
|
|
|
|
TYMED_HGLOBAL = ActiveX.TYMED_HGLOBAL;
|
|
TYMED_ISTREAM = ActiveX.TYMED_ISTREAM;
|
|
DVASPECT_CONTENT = ActiveX.DVASPECT_CONTENT;
|
|
CLSCTX_INPROC_SERVER = ActiveX.CLSCTX_INPROC_SERVER;
|
|
DROPEFFECT_COPY = ActiveX.DROPEFFECT_COPY;
|
|
DROPEFFECT_LINK = ActiveX.DROPEFFECT_LINK;
|
|
DROPEFFECT_MOVE = ActiveX.DROPEFFECT_MOVE;
|
|
DROPEFFECT_NONE = ActiveX.DROPEFFECT_NONE;
|
|
DROPEFFECT_SCROLL = ActiveX.DROPEFFECT_SCROLL;
|
|
DATADIR_GET = ActiveX.DATADIR_GET;
|
|
|
|
type
|
|
//Bridge to ActiveX Types
|
|
IDataObject = ActiveX.IDataObject;
|
|
IDropTarget = ActiveX.IDropTarget;
|
|
IDropSource = ActiveX.IDropSource;
|
|
IEnumFormatEtc = ActiveX.IEnumFORMATETC;
|
|
|
|
//WINOLEAPI = ActiveX.WINOLEAPI;
|
|
|
|
TFormatEtc = ActiveX.TFORMATETC;
|
|
TStgMedium = ActiveX.TStgMedium;
|
|
PDVTargetDevice = ActiveX.PDVTARGETDEVICE;
|
|
|
|
// OLE drag'n drop support
|
|
TFormatEtcArray = array of TFormatEtc;
|
|
TFormatArray = array of Word;
|
|
|
|
// IDataObject.SetData support
|
|
TInternalStgMedium = packed record
|
|
Format: TClipFormat;
|
|
Medium: TStgMedium;
|
|
end;
|
|
TInternalStgMediumArray = array of TInternalStgMedium;
|
|
|
|
TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc)
|
|
private
|
|
FTree: TObject;
|
|
FFormatEtcArray: TFormatEtcArray;
|
|
FCurrentIndex: Integer;
|
|
public
|
|
constructor Create(Tree: TObject; AFormatEtcArray: TFormatEtcArray);
|
|
|
|
function Clone(out Enum: IEnumFormatEtc): HResult; stdcall;
|
|
function Next(celt: LongWord; out elt: FormatEtc; out pceltFetched: LongWord): HResult; stdcall;
|
|
function Reset: HResult; stdcall;
|
|
function Skip(celt: LongWord): HResult; stdcall;
|
|
end;
|
|
|
|
IDropTargetHelper = interface(IUnknown)
|
|
[SID_IDropTargetHelper]
|
|
function DragEnter(hwndTarget: HWND; pDataObject: IDataObject; var ppt: TPoint; dwEffect: LongWord): HRESULT; stdcall;
|
|
function DragLeave: HRESULT; stdcall;
|
|
function DragOver(var ppt: TPoint; dwEffect: LongWord): HRESULT; stdcall;
|
|
function Drop(pDataObject: IDataObject; var ppt: TPoint; dwEffect: LongWord): 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; {$ifdef VER2_0}var{$else}const{$endif} 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: TComponent); 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: LongWord): HResult; stdcall;
|
|
function QueryContinueDrag(EscapePressed: BOOL; KeyState: LongWord): HResult; stdcall;
|
|
end;
|
|
|
|
//Ole helper functions
|
|
|
|
function Succeeded(Status : HRESULT) : BOOLEAN;
|
|
|
|
function Failed(Status : HRESULT) : BOOLEAN;
|
|
|
|
//ActiveX functions that have wrong calling convention in fpc
|
|
|
|
function RegisterDragDrop(hwnd:HWND; pDropTarget:IDropTarget):WINOLEAPI;stdcall;external 'ole32.dll' name 'RegisterDragDrop';
|
|
|
|
function RevokeDragDrop(hwnd:HWND):WINOLEAPI;stdcall;external 'ole32.dll' name 'RevokeDragDrop';
|
|
|
|
function DoDragDrop(pDataObj:IDataObject; pDropSource:IDropSource; dwOKEffects:DWORD; pdwEffect:LPDWORD):WINOLEAPI;stdcall;external 'ole32.dll' name 'DoDragDrop';
|
|
|
|
function OleInitialize(pvReserved:LPVOID):WINOLEAPI;stdcall;external 'ole32.dll' name 'OleInitialize';
|
|
|
|
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';
|
|
|
|
function CreateStreamOnHGlobal(hGlobal:HGLOBAL; fDeleteOnRelease:BOOL;out stm:IStream):WINOLEAPI;stdcall;external 'ole32.dll' name 'CreateStreamOnHGlobal';
|
|
|
|
function CoCreateInstance(const _para1:TCLSID; _para2:IUnknown; _para3:DWORD;const _para4:TIID;out _para5):HRESULT;stdcall; external 'ole32.dll' name 'CoCreateInstance';
|
|
|
|
//helper functions to isolate windows/OLE specific code
|
|
|
|
function RenderOLEData(Tree: TObject; const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;
|
|
ForClipboard: Boolean): HResult;
|
|
|
|
function GetStreamFromMedium(Medium:TStgMedium):TStream;
|
|
|
|
procedure UnlockMediumData(Medium:TStgMedium);
|
|
|
|
function GetTreeFromDataObject(const DataObject: IDataObject; var Format: TFormatEtc): TObject;
|
|
|
|
function AllocateGlobal(Data: Pointer; DataSize:Cardinal): HGLOBAL;
|
|
|
|
implementation
|
|
|
|
uses
|
|
VirtualTrees, Controls, oleutils;
|
|
|
|
type
|
|
TVirtualTreeAccess = class (TBaseVirtualTree)
|
|
end;
|
|
|
|
function Succeeded(Status : HRESULT) : BOOLEAN;
|
|
begin
|
|
Succeeded:=Status and HRESULT($80000000)=0;
|
|
end;
|
|
|
|
function Failed(Status : HRESULT) : BOOLEAN;
|
|
begin
|
|
Failed:=Status and HRESULT($80000000)<>0;
|
|
end;
|
|
|
|
|
|
function RenderOLEData(Tree: TObject; const FormatEtcIn: TFormatEtc; out
|
|
Medium: TStgMedium; ForClipboard: Boolean): HResult;
|
|
|
|
//--------------- local function --------------------------------------------
|
|
|
|
procedure WriteNodes(Stream: TStream);
|
|
|
|
var
|
|
Selection: TNodeArray;
|
|
I: Integer;
|
|
|
|
begin
|
|
with TVirtualTreeAccess(Tree) do
|
|
begin
|
|
if ForClipboard then
|
|
Selection := GetSortedCutCopySet(True)
|
|
else
|
|
Selection := GetSortedSelection(True);
|
|
for I := 0 to High(Selection) do
|
|
WriteNode(Stream, Selection[I]);
|
|
end;
|
|
end;
|
|
|
|
//--------------- end local function ----------------------------------------
|
|
|
|
var
|
|
Data: PCardinal;
|
|
ResPointer: Pointer;
|
|
ResSize: Integer;
|
|
OLEStream: IStream;
|
|
VCLStream: TStream;
|
|
|
|
begin
|
|
VCLStream := nil;
|
|
try
|
|
Medium.PunkForRelease := nil;
|
|
// Return data in one of the supported storage formats, prefer IStream.
|
|
if FormatEtcIn.tymed and TYMED_ISTREAM <> 0 then
|
|
begin
|
|
// Create an IStream on a memory handle (here it is 0 which indicates to implicitely allocated a handle).
|
|
// Do not use TStreamAdapter as it is not compatible with OLE (when flushing the clipboard OLE wants the HGlobal
|
|
// back which is not supported by TStreamAdapater).
|
|
CreateStreamOnHGlobal(0, True, OLEStream);
|
|
|
|
VCLStream := TOLEStream.Create(OLEStream);
|
|
WriteNodes(VCLStream);
|
|
// Rewind stream.
|
|
VCLStream.Position := 0;
|
|
Medium.tymed := TYMED_ISTREAM;
|
|
IUnknown(Medium.Pstm) := OLEStream;
|
|
Result := S_OK;
|
|
end
|
|
else
|
|
begin
|
|
VCLStream := TMemoryStream.Create;
|
|
WriteNodes(VCLStream);
|
|
ResPointer := TMemoryStream(VCLStream).Memory;
|
|
ResSize := VCLStream.Position;
|
|
|
|
// Allocate memory to hold the string.
|
|
if ResSize > 0 then
|
|
begin
|
|
Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, ResSize + SizeOf(Cardinal));
|
|
Data := GlobalLock(Medium.hGlobal);
|
|
// Store the size of the data too, for easy retrival.
|
|
Data^ := ResSize;
|
|
Inc(Data);
|
|
Move(ResPointer^, Data^, ResSize);
|
|
GlobalUnlock(Medium.hGlobal);
|
|
Medium.tymed := TYMED_HGLOBAL;
|
|
|
|
Result := S_OK;
|
|
end
|
|
else
|
|
Result := E_FAIL;
|
|
end;
|
|
finally
|
|
// We can free the VCL stream here since it was either a pure memory stream or only a wrapper around
|
|
// the OLEStream which exists independently.
|
|
VCLStream.Free;
|
|
end;
|
|
end;
|
|
|
|
|
|
type
|
|
// needed to handle OLE global memory objects
|
|
TOLEMemoryStream = class(TCustomMemoryStream)
|
|
public
|
|
function Write(const Buffer; Count: Integer): Longint; override;
|
|
end;
|
|
|
|
//----------------------------------------------------------------------------------------------------------------------
|
|
|
|
function TOLEMemoryStream.Write(const Buffer; Count: Integer): Integer;
|
|
|
|
begin
|
|
{$ifdef COMPILER_5_UP}
|
|
raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError));
|
|
{$else}
|
|
raise EStreamError.Create(SCantWriteResourceStreamError);
|
|
{$endif COMPILER_5_UP}
|
|
end;
|
|
|
|
|
|
function GetStreamFromMedium(Medium: TStgMedium): TStream;
|
|
var
|
|
Data: Pointer;
|
|
I: Integer;
|
|
begin
|
|
Result := nil;
|
|
if Medium.tymed = TYMED_ISTREAM then
|
|
Result := TOLEStream.Create(IUnknown(Medium.Pstm) as IStream)
|
|
else
|
|
begin
|
|
Data := GlobalLock(Medium.hGlobal);
|
|
if Assigned(Data) then
|
|
begin
|
|
// Get the total size of data to retrieve.
|
|
I := PCardinal(Data)^;
|
|
Inc(PCardinal(Data));
|
|
Result := TOLEMemoryStream.Create;
|
|
TOLEMemoryStream(Result).SetPointer(Data, I);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure UnlockMediumData(Medium: TStgMedium);
|
|
begin
|
|
if Medium.tymed = TYMED_HGLOBAL then
|
|
GlobalUnlock(Medium.hGlobal);
|
|
end;
|
|
|
|
function GetTreeFromDataObject(const DataObject: IDataObject;
|
|
var Format: TFormatEtc): TObject;
|
|
|
|
var
|
|
Medium: TStgMedium;
|
|
Data: PVTReference;
|
|
|
|
begin
|
|
Result := nil;
|
|
if Assigned(DataObject) then
|
|
begin
|
|
Format.cfFormat := CF_VTREFERENCE;
|
|
if DataObject.GetData(Format, Medium) = S_OK then
|
|
begin
|
|
Data := GlobalLock(Medium.hGlobal);
|
|
if Assigned(Data) then
|
|
begin
|
|
if Data.Process = GetCurrentProcessID then
|
|
Result := Data.Tree;
|
|
GlobalUnlock(Medium.hGlobal);
|
|
end;
|
|
ReleaseStgMedium(@Medium);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function AllocateGlobal(Data: Pointer; DataSize: Cardinal): HGLOBAL;
|
|
var
|
|
P:Pointer;
|
|
begin
|
|
Result := GlobalAlloc(GHND or GMEM_SHARE, DataSize);
|
|
P := GlobalLock(Result);
|
|
Move(Data^, P^, DataSize);
|
|
GlobalUnlock(Result);
|
|
end;
|
|
|
|
//----------------------------------------------------------------------------------------------------------------------
|
|
|
|
// OLE drag and drop support classes
|
|
// This is quite heavy stuff (compared with the VCL implementation) but is much better suited to fit the needs
|
|
// of DD'ing various kinds of virtual data and works also between applications.
|
|
|
|
//----------------- TEnumFormatEtc -------------------------------------------------------------------------------------
|
|
|
|
constructor TEnumFormatEtc.Create(Tree: TObject; AFormatEtcArray: TFormatEtcArray);
|
|
|
|
var
|
|
I: Integer;
|
|
|
|
begin
|
|
inherited Create;
|
|
|
|
FTree := Tree;
|
|
// Make a local copy of the format data.
|
|
SetLength(FFormatEtcArray, Length(AFormatEtcArray));
|
|
for I := 0 to High(AFormatEtcArray) do
|
|
FFormatEtcArray[I] := AFormatEtcArray[I];
|
|
end;
|
|
|
|
//----------------------------------------------------------------------------------------------------------------------
|
|
|
|
function TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult;
|
|
|
|
var
|
|
AClone: TEnumFormatEtc;
|
|
|
|
begin
|
|
Result := S_OK;
|
|
try
|
|
AClone := TEnumFormatEtc.Create(nil, FFormatEtcArray);
|
|
AClone.FCurrentIndex := FCurrentIndex;
|
|
Enum := AClone as IEnumFormatEtc;
|
|
except
|
|
Result := E_FAIL;
|
|
end;
|
|
end;
|
|
|
|
//----------------------------------------------------------------------------------------------------------------------
|
|
|
|
function TEnumFormatEtc.Next(celt: LongWord; out elt: FormatEtc; out pceltFetched: LongWord): HResult;
|
|
|
|
var
|
|
CopyCount: LongWord;
|
|
|
|
begin
|
|
Result := S_FALSE;
|
|
CopyCount := Length(FFormatEtcArray) - FCurrentIndex;
|
|
if celt < CopyCount then
|
|
CopyCount := celt;
|
|
if CopyCount > 0 then
|
|
begin
|
|
Move(FFormatEtcArray[FCurrentIndex], elt, CopyCount * SizeOf(TFormatEtc));
|
|
Inc(FCurrentIndex, CopyCount);
|
|
Result := S_OK;
|
|
end;
|
|
//todo_lcl_check Delphi treats pceltFetched an PInteger. Implemented like in fpc.activex. What heappens with
|
|
// a C Program call with a NULL in pCeltFetcjed??
|
|
//Answer: Yes. Is necessary a check here
|
|
if @pceltFetched <> nil then
|
|
pceltFetched := CopyCount;
|
|
end;
|
|
|
|
//----------------------------------------------------------------------------------------------------------------------
|
|
|
|
function TEnumFormatEtc.Reset: HResult;
|
|
|
|
begin
|
|
FCurrentIndex := 0;
|
|
Result := S_OK;
|
|
end;
|
|
|
|
//----------------------------------------------------------------------------------------------------------------------
|
|
|
|
function TEnumFormatEtc.Skip(celt: LongWord): HResult;
|
|
|
|
begin
|
|
if FCurrentIndex + celt < High(FFormatEtcArray) then
|
|
begin
|
|
Inc(FCurrentIndex, celt);
|
|
Result := S_Ok;
|
|
end
|
|
else
|
|
Result := S_FALSE;
|
|
end;
|
|
|
|
|
|
//----------------- TVTDataObject --------------------------------------------------------------------------------------
|
|
|
|
constructor TVTDataObject.Create(AOwner: 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;{$ifdef VER2_0}var{$else}const{$endif} Medium: TStgMedium; DoRelease: BOOL): HResult;
|
|
|
|
// Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement
|
|
// IDropSourceHelper and allows to set a special format for optimized moves during a shell transfer.
|
|
|
|
var
|
|
Index: Integer;
|
|
LocalStgMedium: PStgMedium;
|
|
|
|
begin
|
|
// See if we already have a format of that type available.
|
|
Index := FindFormatEtc(FormatEtc, FormatEtcArray);
|
|
if Index > - 1 then
|
|
begin
|
|
// Just use the TFormatEct in the array after releasing the data.
|
|
LocalStgMedium := FindInternalStgMedium(FormatEtcArray[Index].cfFormat);
|
|
if Assigned(LocalStgMedium) then
|
|
begin
|
|
ReleaseStgMedium(LocalStgMedium);
|
|
FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
// It is a new format so create a new TFormatCollectionItem, copy the
|
|
// FormatEtc parameter into the new object and and put it in the list.
|
|
SetLength(FFormatEtcArray, Length(FormatEtcArray) + 1);
|
|
FormatEtcArray[High(FormatEtcArray)] := FormatEtc;
|
|
|
|
// Create a new InternalStgMedium and initialize it and associate it with the format.
|
|
SetLength(FInternalStgMediumArray, Length(InternalStgMediumArray) + 1);
|
|
InternalStgMediumArray[High(InternalStgMediumArray)].Format := FormatEtc.cfFormat;
|
|
LocalStgMedium := @InternalStgMediumArray[High(InternalStgMediumArray)].Medium;
|
|
FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0);
|
|
end;
|
|
|
|
if DoRelease then
|
|
begin
|
|
// We are simply being given the data and we take control of it.
|
|
LocalStgMedium^ := Medium;
|
|
Result := S_OK
|
|
end
|
|
else
|
|
begin
|
|
// We need to reference count or copy the data and keep our own references to it.
|
|
Result := StgMediumIncRef(Medium, LocalStgMedium^, True, Self as IDataObject);
|
|
|
|
// Can get a circular reference if the client calls GetData then calls SetData with the same StgMedium.
|
|
// Because the unkForRelease for the IDataObject can be marshalled it is necessary to get pointers that
|
|
// can be correctly compared. See the IDragSourceHelper article by Raymond Chen at MSDN.
|
|
if Assigned(LocalStgMedium.PunkForRelease) then
|
|
begin
|
|
if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.PunkForRelease)) then
|
|
IUnknown(LocalStgMedium.PunkForRelease) := nil; // release the interface
|
|
end;
|
|
end;
|
|
|
|
// Tell all registered advice sinks about the data change.
|
|
if Assigned(FAdviseHolder) then
|
|
FAdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0);
|
|
end;
|
|
|
|
|
|
//----------------- TVTDragManager -------------------------------------------------------------------------------------
|
|
|
|
constructor TVTDragManager.Create(AOwner: TComponent);
|
|
|
|
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: LongWord): HResult;
|
|
|
|
begin
|
|
Result := DRAGDROP_S_USEDEFAULTCURSORS;
|
|
end;
|
|
|
|
//----------------------------------------------------------------------------------------------------------------------
|
|
|
|
function TVTDragManager.QueryContinueDrag(EscapePressed: BOOL; KeyState: LongWord): 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.
|
|
|