You've already forked lazarus-ccr
Removed direct dependency of ActiveX and OleUtils
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@119 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
blikblum
@ -17,8 +17,33 @@ const
|
||||
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;
|
||||
@ -30,6 +55,19 @@ type
|
||||
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]
|
||||
@ -138,16 +176,273 @@ type
|
||||
function GiveFeedback(Effect: Integer): HResult; stdcall;
|
||||
function QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult; stdcall;
|
||||
end;
|
||||
|
||||
//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);
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
VirtualTrees, Controls;
|
||||
VirtualTrees, Controls, oleutils;
|
||||
|
||||
type
|
||||
TVirtualTreeAccess = class (TBaseVirtualTree)
|
||||
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;
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
// 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);
|
||||
|
||||
Reference in New Issue
Block a user