david
778b05bf9f
- Mustangpeak Common Library - 1.7.0 - EasyListview - 1.7.0 git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.Mustangpeak@2 60b41242-d4b9-2247-b156-4ccd40706241
2355 lines
72 KiB
ObjectPascal
2355 lines
72 KiB
ObjectPascal
unit MPDataObject;
|
|
|
|
// Version 1.7.0
|
|
//
|
|
// The contents of this file are subject to the Mozilla Public License
|
|
// Version 1.1 (the "License"); you may not use this file except in compliance
|
|
// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/
|
|
//
|
|
// Alternatively, you may redistribute this library, use and/or modify it under the terms of the
|
|
// GNU Lesser General Public License as published by the Free Software Foundation;
|
|
// either version 2.1 of the License, or (at your option) any later version.
|
|
// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.
|
|
//
|
|
// Software distributed under the License is distributed on an "AS IS" basis,
|
|
// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the
|
|
// specific language governing rights and limitations under the License.
|
|
//
|
|
// The initial developer of this code is Jim Kueneman <jimdk@mindspring.com>
|
|
// Special thanks to the following in no particular order for their help/support/code
|
|
// Danijel Malik, Robert Lee, Werner Lehmann, Alexey Torgashin, Milan Vandrovec
|
|
//
|
|
//----------------------------------------------------------------------------
|
|
|
|
interface
|
|
|
|
{.$DEFINE GX_DEBUG}
|
|
|
|
{$I Compilers.inc}
|
|
{$I Options.inc}
|
|
{$I ..\Include\Debug.inc}
|
|
{$I ..\Include\Addins.inc}
|
|
|
|
uses
|
|
Windows,
|
|
Messages,
|
|
SysUtils,
|
|
Classes,
|
|
Graphics,
|
|
Controls,
|
|
Forms,
|
|
ActiveX,
|
|
ShlObj,
|
|
ShellAPI,
|
|
{$IFDEF GX_DEBUG}
|
|
DbugIntf,
|
|
{$ENDIF}
|
|
MPShellTypes,
|
|
MPCommonUtilities,
|
|
MPCommonObjects,
|
|
{$IFDEF TNTSUPPORT}
|
|
TntStdCtrls,
|
|
TntClasses,
|
|
TntWideStrings,
|
|
{$ENDIF}
|
|
AxCtrls;
|
|
|
|
const
|
|
// Standard Shell Formats
|
|
CFSTR_LOGICALPERFORMEDDROPEFFECT = 'Logical Performed DropEffect';
|
|
CFSTR_PREFERREDDROPEFFECT = 'Preferred DropEffect';
|
|
CFSTR_PERFORMEDDROPEFFECT = 'Performed DropEffect';
|
|
CFSTR_PASTESUCCEEDED = 'Paste Succeeded';
|
|
CFSTR_INDRAGLOOP = 'InShellDragLoop';
|
|
CFSTR_SHELLIDLISTOFFSET = 'Shell Object Offsets';
|
|
SIZE_SHELLDRAGLOOPDATA = 4;
|
|
|
|
type
|
|
PPerformedDropEffect = ^TPerformedDropEffect;
|
|
TPerformedDropEffect = (
|
|
effectNone, // No Operation (DROPEFFECT_NONE)
|
|
effectCopy, // Operation was a copy (DROPEFFECT_COPY)
|
|
effectMove, // Operation was a move (DROPEFFECT_MOVE)
|
|
effectLink // Operation was a link (DROPEFFECT_LINK)
|
|
);
|
|
|
|
type
|
|
TFormatEtcArray = array of TFormatEtc;
|
|
TDataObjectInfo = record
|
|
FormatEtc: TFormatEtc;
|
|
StgMedium: TStgMedium;
|
|
OwnedByDataObject: Boolean
|
|
end;
|
|
TDataObjectInfoArray = array of TDataObjectInfo;
|
|
|
|
type
|
|
// This is just a WAG for the size. I can't imagine it ever needing this
|
|
// many formats
|
|
TeltArray = array[0..255] of TFormatEtc;
|
|
|
|
{$IFNDEF COMPILER_6_UP}
|
|
PCardinal = ^Cardinal;
|
|
{$ENDIF}
|
|
|
|
//------------------------------------------------------------------------------
|
|
// TCommonEnumFormatEtc :
|
|
// Implements the IEnumFormatEtc interface for the IDataObject
|
|
// implementation. This interface is called by a potential droptarget to see it
|
|
// the IDataObject contains data that the target knows how to handle and would
|
|
// like a shot at accepting it.
|
|
//-------------------------------------------------------------------------------
|
|
|
|
TCommonEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc)
|
|
private
|
|
FInternalIndex: integer;
|
|
FFormats: TFormatEtcArray;
|
|
protected
|
|
{ IEnumFormatEtc }
|
|
function Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; stdcall;
|
|
function Skip(celt: Longint): HResult; stdcall;
|
|
function Reset: HResult; stdcall;
|
|
function Clone(out Enum: IEnumFormatEtc): HResult; stdcall;
|
|
|
|
property InternalIndex: integer read FInternalIndex write FInternalIndex;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
|
|
procedure SetFormatLength(Size: Integer);
|
|
property Formats: TFormatEtcArray read FFormats write FFormats;
|
|
end;
|
|
|
|
//-------------------------------------------------------------------------------}
|
|
// TCommonDataObject : }
|
|
// Implements the IDataObject interface. This interface is called by a }
|
|
// potential droptarget to see it the IDataObject contains data that the target }
|
|
// knows how to handle and would like a shot at accepting it. }
|
|
//-------------------------------------------------------------------------------}
|
|
|
|
ICommonDataObject = interface(IDataObject)
|
|
['{F8B3EE47-C6C1-4FE3-9D94-757AA35DC038}']
|
|
function AssignDragImage(Image: TBitmap; HotSpot: TPoint; TransparentColor: TColor): Boolean;
|
|
function SaveGlobalBlock(Format: TClipFormat; MemoryBlock: Pointer; MemoryBlockSize: integer): Boolean;
|
|
function LoadGlobalBlock(Format: TClipFormat; var MemoryBlock: Pointer): Boolean;
|
|
end;
|
|
|
|
TGetDataEvent = procedure(Sender: TObject; const FormatEtcIn: TFormatEtc; var Medium: TStgMedium; var Handled: Boolean) of object;
|
|
TQueryGetDataEvent = procedure(Sender: TObject; const FormatEtcIn: TFormatEtc; var FormatAvailable: Boolean; var Handled: Boolean) of object;
|
|
|
|
TCommonDataObject = class(TObject, IUnknown, IDataObject, ICommonDataObject, ICommonExtractObj)
|
|
private
|
|
FRefCount: Integer;
|
|
protected
|
|
FAdviseHolder: IDataAdviseHolder;
|
|
FFormats: TDataObjectInfoArray;
|
|
FOnGetData: TGetDataEvent;
|
|
FOnQueryGetData: TQueryGetDataEvent; // Reference to an OLE supplied implementation for advising.
|
|
|
|
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
|
|
function _AddRef: Integer; stdcall;
|
|
function _Release: Integer; stdcall;
|
|
|
|
function CanonicalIUnknown(TestUnknown: IUnknown): IUnknown;
|
|
function DAdvise(const formatetc: TFormatEtc; advf: Longint; const advSink: IAdviseSink; out dwConnection: Longint): HResult; virtual; stdcall;
|
|
function DUnadvise(dwConnection: Longint): HResult; virtual; stdcall;
|
|
function EnumDAdvise(out enumAdvise: IEnumStatData): HResult;virtual; stdcall;
|
|
function EnumFormatEtc(dwDirection: Longint; out enumFormatEtc: IEnumFormatEtc): HResult;virtual; stdcall;
|
|
function EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean;
|
|
function FindFormatEtc(TestFormatEtc: TFormatEtc): integer;
|
|
function GetCanonicalFormatEtc(const formatetc: TFormatEtc; out formatetcOut: TFormatEtc): 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 HGlobalClone(HGlobal: THandle): THandle;
|
|
function QueryGetData(const formatetc: TFormatEtc): HResult;virtual; stdcall;
|
|
function SetData(const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult;virtual; stdcall;
|
|
procedure DoGetCustomFormats(var Formats: TFormatEtcArray); virtual;
|
|
procedure DoOnGetData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium; var Handled: Boolean); virtual;
|
|
procedure DoOnQueryGetData(const FormatEtcIn: TFormatEtc; var FormatAvailable: Boolean; var Handled: Boolean); virtual;
|
|
function RetrieveOwnedStgMedium(Format: TFormatEtc; var StgMedium: TStgMedium): HRESULT;
|
|
function StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium; CopyInMedium: Boolean): HRESULT;
|
|
|
|
function GetObj: TObject;
|
|
|
|
|
|
property AdviseHolder: IDataAdviseHolder read FAdviseHolder;
|
|
property Formats: TDataObjectInfoArray read FFormats write FFormats;
|
|
property Obj: TObject read GetObj;
|
|
property RefCount: Integer read FRefCount;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure AfterConstruction; override;
|
|
procedure BeforeDestruction; override;
|
|
class function NewInstance: TObject; override;
|
|
function AssignDragImage(Image: TBitmap; HotSpot: TPoint; TransparentColor: TColor): Boolean;
|
|
function GetUserData(Format: TFormatEtc; var StgMedium: TStgMedium): Boolean; virtual;
|
|
function LoadGlobalBlock(Format: TClipFormat; var MemoryBlock: Pointer): Boolean;
|
|
function SaveGlobalBlock(Format: TClipFormat; MemoryBlock: Pointer; MemoryBlockSize: integer): Boolean;
|
|
|
|
property OnGetData: TGetDataEvent read FOnGetData write FOnGetData;
|
|
property OnQueryGetData: TQueryGetDataEvent read FOnQueryGetData write FOnQueryGetData;
|
|
end;
|
|
|
|
TCommonClipboardFormat = class
|
|
public
|
|
function GetFormatEtc: TFormatEtc; virtual;
|
|
function LoadFromClipboard: Boolean; virtual;
|
|
function LoadFromDataObject(DataObject: IDataObject): Boolean; virtual; abstract;
|
|
function SaveToClipboard: Boolean; virtual;
|
|
function SaveToDataObject(DataObject: IDataObject): Boolean; virtual; abstract;
|
|
end;
|
|
|
|
TCommonStreamClipFormat = class(TCommonClipboardFormat)
|
|
public
|
|
function GetFormatEtc: TFormatEtc; override;
|
|
function LoadFromClipboard: Boolean; override;
|
|
function LoadFromDataObject(DataObject: IDataObject; CoolStream: TCommonStream): Boolean; reintroduce;
|
|
function SaveToClipboard: Boolean; override;
|
|
function SaveToDataObject(DataObject: IDataObject; CoolStream: TCommonStream): Boolean; reintroduce;
|
|
end;
|
|
|
|
// Simpifies dealing with the CFSTR_FILEGROUPDESCRIPTOR format
|
|
TDescriptorAArray = array of TFileDescriptorA;
|
|
TDescriptorWArray = array of TFileDescriptorW;
|
|
|
|
TFileGroupDescriptorA = class(TCommonClipboardFormat)
|
|
private
|
|
FStream: TStream;
|
|
function GetDescriptorCount: Integer;
|
|
function GetFileDescriptorA(Index: Integer): TFileDescriptorA;
|
|
procedure SetFileDescriptor(Index: Integer;
|
|
const Value: TFileDescriptorA);
|
|
protected
|
|
FFileDescriptors: TDescriptorAArray;
|
|
property Stream: TStream read FStream write FStream;
|
|
public
|
|
procedure AddFileDescriptor(FileDescriptor: TFileDescriptorA);
|
|
procedure DeleteFileDescriptor(Index: integer);
|
|
function GetFormatEtc: TFormatEtc; override;
|
|
function FillDescriptor(FileName: string): TFileDescriptorA;
|
|
function GetFileStream(const DataObject: IDataObject; FileIndex: Integer): TStream;
|
|
procedure LoadFileGroupDestriptor(FileGroupDiscriptor: PFileGroupDescriptorA);
|
|
function LoadFromClipboard: Boolean; override;
|
|
function LoadFromDataObject(DataObject: IDataObject): Boolean; override;
|
|
function SaveToClipboard: Boolean; override;
|
|
function SaveToDataObject(DataObject: IDataObject): Boolean; override;
|
|
|
|
property DescriptorCount: Integer read GetDescriptorCount;
|
|
property FileDescriptor[Index: Integer]: TFileDescriptorA read GetFileDescriptorA write SetFileDescriptor;
|
|
end;
|
|
|
|
TFileGroupDescriptorW = class(TCommonClipboardFormat)
|
|
private
|
|
FStream: TStream;
|
|
function GetDescriptorCount: Integer;
|
|
function GetFileDescriptorW(Index: Integer): TFileDescriptorW;
|
|
procedure SetFileDescriptor(Index: Integer;
|
|
const Value: TFileDescriptorW);
|
|
protected
|
|
FFileDescriptors: TDescriptorWArray;
|
|
property Stream: TStream read FStream write FStream;
|
|
public
|
|
procedure AddFileDescriptor(FileDescriptor: TFileDescriptorW);
|
|
procedure DeleteFileDescriptor(Index: integer);
|
|
function FillDescriptor(FileName: WideString): TFileDescriptorW;
|
|
function GetFileStream(const DataObject: IDataObject; FileIndex: Integer): TStream;
|
|
function GetFormatEtc: TFormatEtc; override;
|
|
procedure LoadFileGroupDestriptor(FileGroupDiscriptor: PFileGroupDescriptorW);
|
|
function LoadFromClipboard: Boolean; override;
|
|
function LoadFromDataObject(DataObject: IDataObject): Boolean; override;
|
|
function SaveToClipboard: Boolean; override;
|
|
function SaveToDataObject(DataObject: IDataObject): Boolean; override;
|
|
|
|
property DescriptorCount: Integer read GetDescriptorCount;
|
|
property FileDescriptor[Index: Integer]: TFileDescriptorW read GetFileDescriptorW write SetFileDescriptor;
|
|
end;
|
|
|
|
// Simpifies dealing with the CF_HDROP format
|
|
TCommonHDrop = class(TCommonClipboardFormat)
|
|
private
|
|
procedure SetDropFiles(const Value: PDropFiles);
|
|
function GetHDropStruct: THandle;
|
|
protected
|
|
FDropFiles: PDropFiles;
|
|
FStructureSize: integer;
|
|
FFileCount: integer;
|
|
|
|
procedure AllocStructure(Size: integer);
|
|
function CalculateDropFileStructureSizeA(Value: PDropFiles): integer;
|
|
function CalculateDropFileStructureSizeW(Value: PDropFiles): integer;
|
|
function FileCountA: Integer;
|
|
function FileCountW: Integer;
|
|
function FileNameA(Index: integer): string;
|
|
function FileNameW(Index: integer): WideString;
|
|
procedure FreeStructure; // Frees memory allocated
|
|
public
|
|
destructor Destroy; override;
|
|
function AssignFromClipboard: Boolean;
|
|
function LoadFromClipboard: Boolean; override;
|
|
function LoadFromDataObject(DataObject: IDataObject): Boolean; override;
|
|
function FileCount: integer;
|
|
function FileName(Index: integer): WideString;
|
|
function GetFormatEtc: TFormatEtc; override;
|
|
procedure AssignFilesA(FileList: TStringList);
|
|
{$IFDEF TNTSUPPORT}
|
|
procedure AssignFilesW(FileList: TWideStrings);
|
|
procedure FileNamesW(FileList: TWideStrings);
|
|
{$ENDIF}
|
|
procedure FileNamesA(FileList: TStrings);
|
|
|
|
property HDropStruct: THandle read GetHDropStruct;
|
|
function SaveToClipboard: Boolean; override;
|
|
function SaveToDataObject(DataObject: IDataObject): Boolean; override;
|
|
property StructureSize: integer read FStructureSize;
|
|
property DropFiles: PDropFiles read FDropFiles write SetDropFiles;
|
|
end;
|
|
|
|
// Simpifies dealing with the CFSTR_SHELLIDLIST format
|
|
type
|
|
TCommonShellIDList = class(TCommonClipboardFormat)
|
|
private
|
|
FCIDA: PIDA;
|
|
function GetCIDASize: integer;
|
|
function InternalChildPIDL(Index: integer): PItemIDList;
|
|
function InternalParentPIDL: PItemIDList;
|
|
procedure SetCIDA(const Value: PIDA);
|
|
public
|
|
function AbsolutePIDL(Index: integer): PItemIDList;
|
|
procedure AbsolutePIDLs(APIDLList: TCommonPIDLList);
|
|
procedure AssignPIDLs(APIDLList: TCommonPIDLList);
|
|
destructor Destroy; override;
|
|
function GetFormatEtc: TFormatEtc; override;
|
|
function LoadFromClipboard: Boolean; override;
|
|
function LoadFromDataObject(DataObject: IDataObject): Boolean; override;
|
|
function ParentPIDL: PItemIDList;
|
|
function PIDLCount: integer;
|
|
function RelativePIDL(Index: integer): PItemIDList;
|
|
procedure RelativePIDLs(APIDLList: TCommonPIDLList);
|
|
function SaveToClipboard: Boolean; override;
|
|
function SaveToDataObject(DataObject: IDataObject): Boolean; override;
|
|
|
|
property CIDA: PIDA read FCIDA write SetCIDA;
|
|
property CIDASize: integer read GetCIDASize;
|
|
end;
|
|
|
|
// Simpilies dealing with the CFSTR_LOGICALPERFORMEDDROPEFFECT format
|
|
TCommonLogicalPerformedDropEffect = class(TCommonClipboardFormat)
|
|
private
|
|
FAction: TPerformedDropEffect;
|
|
public
|
|
function GetFormatEtc: TFormatEtc; override;
|
|
function LoadFromDataObject(DataObject: IDataObject): Boolean; override;
|
|
function SaveToDataObject(DataObject: IDataObject): Boolean; override;
|
|
|
|
property Action: TPerformedDropEffect read FAction write FAction;
|
|
end;
|
|
|
|
// Simpilies dealing with the CFSTR_PerferredDropEffect format
|
|
TCommonPreferredDropEffect = class(TCommonLogicalPerformedDropEffect)
|
|
public
|
|
function GetFormatEtc: TFormatEtc; override;
|
|
end;
|
|
|
|
TCommonInShellDragLoop = class(TCommonClipboardFormat)
|
|
private
|
|
FData: Cardinal;
|
|
public
|
|
function GetFormatEtc: TFormatEtc; override;
|
|
function LoadFromDataObject(DataObject: IDataObject): Boolean; override;
|
|
function SaveToDataObject(DataObject: IDataObject): Boolean; override;
|
|
property Data: Cardinal read FData write FData;
|
|
end;
|
|
|
|
function FillFormatEtc(cfFormat: Word; ptd: PDVTargetDevice = nil;
|
|
dwAspect: Longint = DVASPECT_CONTENT; lindex: Longint = -1; tymed: Longint = TYMED_HGLOBAL): TFormatEtc;
|
|
function DataObjectSupportsShell(const DataObj: IDataObject): Boolean;
|
|
function DataObjectContainsPIDL(APIDL: PItemIDList; const DataObj: IDataObject): Boolean;
|
|
|
|
function HDropFormat: TFormatEtc;
|
|
function ShellIDListFormat: TFormatEtc;
|
|
function FileDescriptorAFormat: TFormatEtc;
|
|
function FileDescriptorWFormat: TFormatEtc;
|
|
|
|
var
|
|
CF_SHELLIDLIST,
|
|
CF_PERFORMEDDROPEFFECT,
|
|
CF_PASTESUCCEEDED,
|
|
CF_INDRAGLOOP,
|
|
CF_SHELLIDLISTOFFSET,
|
|
CF_LOGICALPERFORMEDDROPEFFECT,
|
|
CF_PREFERREDDROPEFFECT,
|
|
CF_FILECONTENTS,
|
|
CF_FILEDESCRIPTORA,
|
|
CF_FILEDESCRIPTORW: TClipFormat;
|
|
|
|
implementation
|
|
|
|
var
|
|
PIDLMgr: TCommonPIDLManager;
|
|
ShellILIsEqual: function(PIDL1: PItemIDList; PIDL2: PItemIDList): LongBool; stdcall;
|
|
ShellILIsEqualChecked: Boolean = False;
|
|
|
|
|
|
function LoadShellILIsEqual: Boolean;
|
|
begin
|
|
if not ShellILIsEqualChecked then
|
|
begin
|
|
ShellILIsEqual := GetProcAddress(GetModuleHandle(PChar(Shell32)), PChar(21));
|
|
ShellILIsEqualChecked := True;
|
|
end;
|
|
Result := Assigned(ShellILIsEqual)
|
|
end;
|
|
|
|
function DataObjectContainsPIDL(APIDL: PItemIDList; const DataObj: IDataObject): Boolean;
|
|
var
|
|
ShellIDList: TCommonShellIDList;
|
|
i: Integer;
|
|
P: PItemIDList;
|
|
begin
|
|
Result := False;
|
|
;
|
|
if Assigned(DataObj) and Assigned(APIDL) and LoadShellILIsEqual then
|
|
begin
|
|
if Succeeded(DataObj.QueryGetData(ShellIDListFormat)) then
|
|
begin
|
|
ShellIDList := TCommonShellIDList.Create;
|
|
try
|
|
if ShellIDList.LoadFromDataObject(DataObj) then
|
|
begin
|
|
i := 0;
|
|
while not Result and (i < ShellIDList.PIDLCount) do
|
|
begin
|
|
P := ShellIDList.AbsolutePIDL(i);
|
|
Result := ShellILIsEqual(P, APIDL);
|
|
PIDLMgr.FreePIDL(P);
|
|
Inc(i)
|
|
end
|
|
end
|
|
finally
|
|
ShellIDList.Free
|
|
end
|
|
end
|
|
end
|
|
end;
|
|
|
|
function DataObjectSupportsShell(const DataObj: IDataObject): Boolean;
|
|
begin
|
|
Result := False;
|
|
if Assigned(DataObj) then
|
|
begin
|
|
Result := Succeeded(DataObj.QueryGetData(HDropFormat)) or
|
|
Succeeded(DataObj.QueryGetData(ShellIDListFormat)) or
|
|
Succeeded(DataObj.QueryGetData(FileDescriptorAFormat)) or
|
|
Succeeded(DataObj.QueryGetData(FileDescriptorWFormat))
|
|
end
|
|
end;
|
|
|
|
function HDropFormat: TFormatEtc;
|
|
begin
|
|
Result.cfFormat := CF_HDROP; // This guy is always registered for all applications
|
|
Result.ptd := nil;
|
|
Result.dwAspect := DVASPECT_CONTENT;
|
|
Result.lindex := -1;
|
|
Result.tymed := TYMED_HGLOBAL
|
|
end;
|
|
|
|
function ShellIDListFormat: TFormatEtc;
|
|
begin
|
|
Result.cfFormat := CF_SHELLIDLIST;
|
|
Result.ptd := nil;
|
|
Result.dwAspect := DVASPECT_CONTENT;
|
|
Result.lindex := -1;
|
|
Result.tymed := TYMED_HGLOBAL;
|
|
end;
|
|
|
|
function FileDescriptorAFormat: TFormatEtc;
|
|
begin
|
|
Result.cfFormat := CF_FILEDESCRIPTORA;
|
|
Result.ptd := nil;
|
|
Result.dwAspect := DVASPECT_CONTENT;
|
|
Result.lindex := -1;
|
|
Result.tymed := TYMED_HGLOBAL
|
|
end;
|
|
|
|
function FileDescriptorWFormat: TFormatEtc;
|
|
begin
|
|
Result.cfFormat := CF_FILEDESCRIPTORW;
|
|
Result.ptd := nil;
|
|
Result.dwAspect := DVASPECT_CONTENT;
|
|
Result.lindex := -1;
|
|
Result.tymed := TYMED_HGLOBAL
|
|
end;
|
|
|
|
function FillFormatEtc(cfFormat: Word; ptd: PDVTargetDevice = nil;
|
|
dwAspect: Longint = DVASPECT_CONTENT; lindex: Longint = -1; tymed: Longint = TYMED_HGLOBAL): TFormatEtc;
|
|
begin
|
|
Result.cfFormat := cfFormat;
|
|
Result.ptd := ptd;
|
|
Result.dwAspect := dwAspect;
|
|
Result.lindex := lindex;
|
|
Result.tymed := tymed
|
|
end;
|
|
|
|
{ TCommonClipboardFormat }
|
|
|
|
function TCommonClipboardFormat.GetFormatEtc: TFormatEtc;
|
|
begin
|
|
FillChar(Result, SizeOf(Result), #0);
|
|
end;
|
|
|
|
function TCommonClipboardFormat.LoadFromClipboard: Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TCommonClipboardFormat.SaveToClipboard: Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
{ TLogicalPerformedDropEffect }
|
|
|
|
function TCommonLogicalPerformedDropEffect.GetFormatEtc: TFormatEtc;
|
|
begin
|
|
Result.cfFormat := CF_LOGICALPERFORMEDDROPEFFECT;
|
|
Result.ptd := nil;
|
|
Result.dwAspect := DVASPECT_CONTENT;
|
|
Result.lindex := -1;
|
|
Result.tymed := TYMED_HGLOBAL
|
|
end;
|
|
|
|
function TCommonLogicalPerformedDropEffect.LoadFromDataObject(DataObject: IDataObject): Boolean;
|
|
var
|
|
Ptr: PPerformedDropEffect;
|
|
StgMedium: TStgMedium;
|
|
begin
|
|
Result := False;
|
|
FillChar(StgMedium, SizeOf(StgMedium), #0);
|
|
|
|
if Succeeded(DataObject.GetData(GetFormatEtc, StgMedium)) then
|
|
try
|
|
Ptr := GlobalLock(StgMedium.hGlobal);
|
|
try
|
|
if Assigned(Ptr) then
|
|
begin
|
|
FAction := Ptr^;
|
|
Result := True;
|
|
end;
|
|
finally
|
|
GlobalUnLock(StgMedium.hGlobal);
|
|
end
|
|
finally
|
|
ReleaseStgMedium(StgMedium)
|
|
end
|
|
end;
|
|
|
|
function TCommonLogicalPerformedDropEffect.SaveToDataObject(DataObject: IDataObject): Boolean;
|
|
var
|
|
Ptr: PPerformedDropEffect;
|
|
StgMedium: TStgMedium;
|
|
begin
|
|
FillChar(StgMedium, SizeOf(StgMedium), #0);
|
|
|
|
StgMedium.hGlobal := GlobalAlloc(GPTR, SizeOf(FAction));
|
|
Ptr := GlobalLock(StgMedium.hGlobal);
|
|
try
|
|
Ptr^ := FAction;
|
|
StgMedium.tymed := TYMED_HGLOBAL;
|
|
Result := Succeeded(DataObject.SetData(GetFormatEtc, StgMedium, True))
|
|
finally
|
|
GlobalUnLock(StgMedium.hGlobal);
|
|
end
|
|
end;
|
|
|
|
{ THDrop }
|
|
|
|
procedure TCommonHDrop.AllocStructure(Size: integer);
|
|
begin
|
|
FreeStructure;
|
|
GetMem(FDropFiles, Size);
|
|
FStructureSize := Size;
|
|
FillChar(FDropFiles^, Size, #0);
|
|
end;
|
|
|
|
procedure TCommonHDrop.AssignFilesA(FileList: TStringList);
|
|
var
|
|
i: Integer;
|
|
Size: integer;
|
|
Path: PChar;
|
|
begin
|
|
if Assigned(FileList) then
|
|
begin
|
|
FreeStructure;
|
|
Size := 0;
|
|
for i := 0 to FileList.Count - 1 do
|
|
Inc(Size, Length(FileList[i]) + SizeOf(Char)); // add spot for the null
|
|
Inc(Size, SizeOf(TDropFiles));
|
|
Inc(Size, SizeOf(Char)); // room for the terminating null
|
|
AllocStructure(Size);
|
|
DropFiles.pFiles := SizeOf(TDropFiles);
|
|
DropFiles.pt.x := 0;
|
|
DropFiles.pt.y := 0;
|
|
DropFiles.fNC := False;
|
|
DropFiles.fWide := False; // Don't support wide char let NT convert it
|
|
Path := PChar(FDropFiles) + FDropFiles.pFiles;
|
|
for i := 0 to FileList.Count - 1 do
|
|
begin
|
|
MoveMemory(Path, Pointer(FileList[i]), Length(FileList[i]));
|
|
Inc(Path, Length(FileList[i]) + 1); // skip over the single null #0
|
|
end
|
|
end
|
|
end;
|
|
|
|
function TCommonHDrop.AssignFromClipboard: Boolean;
|
|
var
|
|
Handle: THandle;
|
|
Ptr: PDropFiles;
|
|
begin
|
|
Result := False;
|
|
Handle := 0;
|
|
OpenClipboard(Application.Handle);
|
|
try
|
|
Handle := GetClipboardData(CF_HDROP);
|
|
if Handle <> 0 then
|
|
begin
|
|
Ptr := GlobalLock(Handle);
|
|
if Assigned(Ptr) then
|
|
begin
|
|
DropFiles := Ptr;
|
|
Result := True;
|
|
end;
|
|
end;
|
|
finally
|
|
CloseClipboard;
|
|
GlobalUnLock(Handle);
|
|
end;
|
|
end;
|
|
|
|
function TCommonHDrop.CalculateDropFileStructureSizeA(
|
|
Value: PDropFiles): integer;
|
|
var
|
|
Head: PChar;
|
|
Len: integer;
|
|
begin
|
|
if Assigned(Value) then
|
|
begin
|
|
Result := Value^.pFiles;
|
|
Head := PChar( Value) + Value^.pFiles;
|
|
Len := lstrlen(Head);
|
|
while Len > 0 do
|
|
begin
|
|
Result := Result + Len + 1;
|
|
Head := Head + Len + 1;
|
|
Len := lstrlen(Head);
|
|
end;
|
|
Inc(Result, 1); // Add second null
|
|
end else
|
|
Result := 0
|
|
end;
|
|
|
|
function TCommonHDrop.CalculateDropFileStructureSizeW(
|
|
Value: PDropFiles): integer;
|
|
var
|
|
Head: PChar;
|
|
Len: integer;
|
|
begin
|
|
if Assigned(Value) then
|
|
begin
|
|
Result := Value^.pFiles;
|
|
Head := PChar( Value) + Value^.pFiles;
|
|
Len := 2 * (lstrlenW(PWideChar( Head)));
|
|
while Len > 0 do
|
|
begin
|
|
Result := Result + Len + 2;
|
|
Head := Head + Len + 2;
|
|
Len := 2 * (lstrlenW(PWideChar( Head)));
|
|
end;
|
|
Inc(Result, 2); // Add second null
|
|
end else
|
|
Result := 0
|
|
end;
|
|
|
|
destructor TCommonHDrop.Destroy;
|
|
begin
|
|
FreeStructure;
|
|
inherited;
|
|
end;
|
|
|
|
function TCommonHDrop.FileCount: integer;
|
|
begin
|
|
if Assigned(DropFiles) then
|
|
begin
|
|
if FFileCount = 0 then
|
|
begin
|
|
if DropFiles.fWide then
|
|
Result := FileCountW
|
|
else
|
|
Result := FileCountA;
|
|
FFileCount := Result;
|
|
end;
|
|
end else
|
|
FFileCount := 0;
|
|
Result := FFileCount
|
|
end;
|
|
|
|
function TCommonHDrop.FileCountA: Integer;
|
|
var
|
|
Head: PChar;
|
|
Len: integer;
|
|
begin
|
|
Result := 0;
|
|
if Assigned(DropFiles) then
|
|
begin
|
|
Head := PChar( DropFiles) + DropFiles^.pFiles;
|
|
Len := lstrlen(Head);
|
|
while Len > 0 do
|
|
begin
|
|
Head := Head + Len + 1;
|
|
Inc(Result);
|
|
Len := lstrlen(Head);
|
|
end
|
|
end
|
|
end;
|
|
|
|
function TCommonHDrop.FileCountW: Integer;
|
|
var
|
|
Head: PChar;
|
|
Len: integer;
|
|
begin
|
|
Result := 0;
|
|
if Assigned(DropFiles) then
|
|
begin
|
|
Head := PChar( DropFiles) + DropFiles^.pFiles;
|
|
Len := 2 * (lstrlenW(PWideChar( Head)));
|
|
while Len > 0 do
|
|
begin
|
|
Head := Head + Len + 2;
|
|
Inc(Result);
|
|
Len := 2 * (lstrlenW(PWideChar( Head)));
|
|
end
|
|
end;
|
|
end;
|
|
|
|
function TCommonHDrop.FileName(Index: integer): WideString;
|
|
begin
|
|
if Assigned(DropFiles) then
|
|
begin
|
|
if DropFiles.fWide then
|
|
Result := FileNameW(Index)
|
|
else
|
|
Result := FileNameA(Index)
|
|
end
|
|
end;
|
|
|
|
function TCommonHDrop.FileNameA(Index: integer): string;
|
|
var
|
|
Head: PChar;
|
|
PathNameCount: integer;
|
|
Done: Boolean;
|
|
Len: integer;
|
|
begin
|
|
PathNameCount := 0;
|
|
Done := False;
|
|
if Assigned(DropFiles) then
|
|
begin
|
|
Head := PChar( DropFiles) + DropFiles^.pFiles;
|
|
Len := lstrlen(Head);
|
|
while (not Done) and (PathNameCount < FileCount) do
|
|
begin
|
|
if PathNameCount = Index then
|
|
begin
|
|
SetLength(Result, Len + 1);
|
|
CopyMemory(@Result[1], Head, Len + 1); // Include the NULL
|
|
Done := True;
|
|
end;
|
|
Head := Head + Len + 1;
|
|
Inc(PathNameCount);
|
|
Len := lstrlen(Head);
|
|
end
|
|
end
|
|
end;
|
|
|
|
{$IFDEF TNTSUPPORT}
|
|
procedure TCommonHDrop.AssignFilesW(FileList: TWideStrings);
|
|
var
|
|
i: Integer;
|
|
Size: integer;
|
|
Path: PChar;
|
|
ByteSize: Integer;
|
|
begin
|
|
if Assigned(FileList) then
|
|
begin
|
|
FreeStructure;
|
|
Size := 0;
|
|
if UnicodeStringLists then
|
|
ByteSize := 2
|
|
else
|
|
ByteSize := 1;
|
|
for i := 0 to FileList.Count - 1 do
|
|
Inc(Size, (Length(FileList[i])+1)*(SizeOf(Char)*ByteSize)); // add spot for the null
|
|
Inc(Size, SizeOf(TDropFiles));
|
|
Inc(Size, SizeOf(Char)*2); // room for the terminating null
|
|
AllocStructure(Size);
|
|
DropFiles.pFiles := SizeOf(TDropFiles);
|
|
DropFiles.pt.x := 0;
|
|
DropFiles.pt.y := 0;
|
|
DropFiles.fNC := False;
|
|
DropFiles.fWide := UnicodeStringLists;
|
|
Path := PChar(FDropFiles) + FDropFiles.pFiles;
|
|
for i := 0 to FileList.Count - 1 do
|
|
begin
|
|
MoveMemory(Path, Pointer(FileList[i]), Length(FileList[i])*ByteSize);
|
|
Inc(Path, (Length(FileList[i]) + 1)*ByteSize); // skip over the single null #0
|
|
end
|
|
end
|
|
end;
|
|
|
|
procedure TCommonHDrop.FileNamesW(FileList: TWideStrings);
|
|
var
|
|
i: integer;
|
|
begin
|
|
if Assigned(FileList) then
|
|
begin
|
|
for i := 0 to FileCount - 1 do
|
|
FileList.Add(FileNameW(i));
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure TCommonHDrop.FileNamesA(FileList: TStrings);
|
|
var
|
|
i: integer;
|
|
begin
|
|
if Assigned(FileList) then
|
|
begin
|
|
for i := 0 to FileCount - 1 do
|
|
FileList.Add(FileName(i));
|
|
end;
|
|
end;
|
|
|
|
function TCommonHDrop.FileNameW(Index: integer): WideString;
|
|
var
|
|
Head: PChar;
|
|
PathNameCount: integer;
|
|
Done: Boolean;
|
|
Len: integer;
|
|
begin
|
|
PathNameCount := 0;
|
|
Done := False;
|
|
if Assigned(DropFiles) then
|
|
begin
|
|
Head := PChar( DropFiles) + DropFiles^.pFiles;
|
|
Len := 2 * (lstrlenW(PWideChar( Head)));
|
|
while (not Done) and (PathNameCount < FileCount) do
|
|
begin
|
|
if PathNameCount = Index then
|
|
begin
|
|
SetLength(Result, (Len + 1) div 2);
|
|
CopyMemory(@Result[1], Head, Len + 2); // Include the NULL
|
|
Done := True;
|
|
end;
|
|
Head := Head + Len + 2;
|
|
Inc(PathNameCount);
|
|
Len := 2 * (lstrlenW(PWideChar( Head)));
|
|
end
|
|
end
|
|
end;
|
|
|
|
procedure TCommonHDrop.FreeStructure;
|
|
begin
|
|
FFileCount := 0;
|
|
if Assigned(FDropFiles) then
|
|
FreeMem(FDropFiles, FStructureSize);
|
|
FDropFiles := nil;
|
|
FStructureSize := 0;
|
|
end;
|
|
|
|
function TCommonHDrop.GetFormatEtc: TFormatEtc;
|
|
begin
|
|
Result.cfFormat := CF_HDROP; // This guy is always registered for all applications
|
|
Result.ptd := nil;
|
|
Result.dwAspect := DVASPECT_CONTENT;
|
|
Result.lindex := -1;
|
|
Result.tymed := TYMED_HGLOBAL
|
|
end;
|
|
|
|
function TCommonHDrop.GetHDropStruct: THandle;
|
|
var
|
|
Files: PDropFiles;
|
|
begin
|
|
Result := GlobalAlloc(GHND, StructureSize);
|
|
Files := GlobalLock(Result);
|
|
try
|
|
MoveMemory(Files, FDropFiles, StructureSize);
|
|
finally
|
|
GlobalUnlock(Result)
|
|
end;
|
|
end;
|
|
|
|
function TCommonHDrop.LoadFromClipboard: Boolean;
|
|
var
|
|
Handle: THandle;
|
|
Ptr: PDropFiles;
|
|
begin
|
|
Result := False;
|
|
Handle := 0;
|
|
OpenClipboard(Application.Handle);
|
|
try
|
|
Handle := GetClipboardData(CF_HDROP);
|
|
if Handle <> 0 then
|
|
begin
|
|
Ptr := GlobalLock(Handle);
|
|
if Assigned(Ptr) then
|
|
begin
|
|
DropFiles := Ptr;
|
|
Result := True;
|
|
end;
|
|
end;
|
|
finally
|
|
CloseClipboard;
|
|
GlobalUnLock(Handle);
|
|
end;
|
|
end;
|
|
|
|
function TCommonHDrop.LoadFromDataObject(DataObject: IDataObject): Boolean;
|
|
var
|
|
Medium: TStgMedium;
|
|
Files: PDropFiles;
|
|
begin
|
|
Result := False;
|
|
if Assigned(DataObject) then
|
|
begin
|
|
if Succeeded(DataObject.GetData(GetFormatEtc, Medium)) then
|
|
try
|
|
Files := GlobalLock(Medium.hGlobal);
|
|
try
|
|
DropFiles := Files
|
|
finally
|
|
GlobalUnlock(Medium.hGlobal)
|
|
end
|
|
finally
|
|
ReleaseStgMedium(Medium)
|
|
end;
|
|
Result := Assigned(DropFiles)
|
|
end
|
|
end;
|
|
|
|
function TCommonHDrop.SaveToClipboard: Boolean;
|
|
begin
|
|
Result := False;
|
|
OpenClipboard(Application.Handle);
|
|
try
|
|
SetClipboardData(CF_HDROP, HDropStruct)
|
|
finally
|
|
CloseClipboard;
|
|
end;
|
|
end;
|
|
|
|
function TCommonHDrop.SaveToDataObject(DataObject: IDataObject): Boolean;
|
|
var
|
|
Medium: TStgMedium;
|
|
begin
|
|
Result := False;
|
|
FillChar(Medium, SizeOf(Medium), #0);
|
|
Medium.tymed := TYMED_HGLOBAL;
|
|
Medium.hGlobal := HDropStruct;
|
|
// Give the block to the DataObject
|
|
if Succeeded(DataObject.SetData(GetFormatEtc, Medium, True)) then
|
|
Result := True
|
|
else
|
|
GlobalFree(Medium.hGlobal)
|
|
end;
|
|
|
|
procedure TCommonHDrop.SetDropFiles(const Value: PDropFiles);
|
|
begin
|
|
FreeStructure;
|
|
if Assigned(Value) then
|
|
begin
|
|
if Value.fWide then
|
|
FStructureSize := CalculateDropFileStructureSizeW(Value)
|
|
else
|
|
FStructureSize := CalculateDropFileStructureSizeA(Value);
|
|
AllocStructure(StructureSize);
|
|
CopyMemory(FDropFiles, Value, StructureSize);
|
|
end;
|
|
end;
|
|
|
|
{ TPreferredDropEffect }
|
|
|
|
function TCommonPreferredDropEffect.GetFormatEtc: TFormatEtc;
|
|
begin
|
|
Result.cfFormat := CF_PREFERREDDROPEFFECT;
|
|
Result.ptd := nil;
|
|
Result.dwAspect := DVASPECT_CONTENT;
|
|
Result.lindex := -1;
|
|
Result.tymed := TYMED_HGLOBAL
|
|
end;
|
|
|
|
{ TCoolStreamClipFormat }
|
|
|
|
function TCommonStreamClipFormat.GetFormatEtc: TFormatEtc;
|
|
begin
|
|
Result.cfFormat := 0;
|
|
Result.ptd := nil;
|
|
Result.dwAspect := DVASPECT_CONTENT;
|
|
Result.lindex := -1;
|
|
Result.tymed := TYMED_HGLOBAL
|
|
end;
|
|
|
|
function TCommonStreamClipFormat.LoadFromClipboard: Boolean;
|
|
begin
|
|
Result := False;
|
|
Assert(True=False, 'TCoolStream.LoadFromClipboard not Implemented');
|
|
end;
|
|
|
|
function TCommonStreamClipFormat.LoadFromDataObject(DataObject: IDataObject;
|
|
CoolStream: TCommonStream): Boolean;
|
|
var
|
|
Medium: TStgMedium;
|
|
PMem, PSize: Pointer;
|
|
Size: Int64;
|
|
begin
|
|
Result := False;
|
|
if Succeeded(DataObject.GetData(GetFormatEtc, Medium)) then
|
|
begin
|
|
PMem := GlobalLock(Medium.hGlobal);
|
|
try
|
|
PSize := @Size;
|
|
// Get the size of the Stream
|
|
MoveMemory(PMem, PSize, SizeOf(Int64));
|
|
|
|
CoolStream.Seek(0, soFromBeginning);
|
|
CoolStream.SetSize(Size);
|
|
|
|
Inc(PChar( PMem), SizeOf(Int64));
|
|
|
|
// Copy the data to the stream
|
|
MoveMemory(PMem, CoolStream.Memory, Size);
|
|
finally
|
|
GlobalUnlock(Medium.hGlobal);
|
|
ReleaseStgMedium(Medium);
|
|
end
|
|
end
|
|
end;
|
|
|
|
function TCommonStreamClipFormat.SaveToClipboard: Boolean;
|
|
begin
|
|
Result := False;
|
|
Assert(True=False, 'TCoolStream.SaveToClipboard not Implemented');
|
|
end;
|
|
|
|
function TCommonStreamClipFormat.SaveToDataObject(DataObject: IDataObject;
|
|
CoolStream: TCommonStream): Boolean;
|
|
var
|
|
Medium: TStgMedium;
|
|
Mem: HGlobal;
|
|
PMem: Pointer;
|
|
Size: Int64;
|
|
PSize: Pointer;
|
|
begin
|
|
Mem := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE, CoolStream.Size + SizeOf(Int64));
|
|
PMem := GlobalLock(Mem);
|
|
try
|
|
FillChar(Medium, SizeOf(Medium), #0);
|
|
|
|
PSize := @Size;
|
|
|
|
// Write the size of the Stream to the block
|
|
Size := CoolStream.Size;
|
|
MoveMemory(PMem, PSize, SizeOf(Int64));
|
|
|
|
// Copy the Stream to a global memory block
|
|
MoveMemory(PMem, CoolStream.Memory, CoolStream.Size);
|
|
|
|
// Transfer the data with a global memory block
|
|
Medium.tymed := TYMED_HGLOBAL;
|
|
Medium.hGlobal := Mem;
|
|
|
|
// Give it to the DataObject so it may destroy it when the clients are done
|
|
Result := Succeeded(DataObject.SetData(GetFormatEtc, Medium, True))
|
|
finally
|
|
GlobalUnlock(Mem)
|
|
end
|
|
end;
|
|
|
|
{ TShellIDList }
|
|
|
|
function TCommonShellIDList.AbsolutePIDL(Index: integer): PItemIDList;
|
|
{ Appends the single ItemID with the Parent folder to create an Absolute PIDL }
|
|
begin
|
|
if Assigned(FCIDA) then
|
|
begin
|
|
Result := PIDLMgr.AppendPIDL(InternalParentPIDL, InternalChildPIDL(Index));
|
|
end else
|
|
Result := nil
|
|
end;
|
|
|
|
procedure TCommonShellIDList.AbsolutePIDLs(APIDLList: TCommonPIDLList);
|
|
var
|
|
i: integer;
|
|
begin
|
|
if Assigned(APIDLList) and Assigned(FCIDA) then
|
|
begin
|
|
for i := 0 to PIDLCount - 1 do
|
|
APIDLList.Add( PIDLMgr.AppendPIDL(InternalParentPIDL, InternalChildPIDL(i)))
|
|
end;
|
|
end;
|
|
|
|
procedure TCommonShellIDList.AssignPIDLs(APIDLList: TCommonPIDLList);
|
|
{ PIDLs[0] must be the Absolute Parent PIDL and the rest single ItemID children }
|
|
var
|
|
Count: Integer;
|
|
i: Integer;
|
|
Head: Pointer;
|
|
PIDLLength: Integer;
|
|
begin
|
|
Count := 0;
|
|
if Assigned(APIDLList) then
|
|
begin
|
|
{ Free previously assigned CIDA }
|
|
if Assigned(FCIDA) then
|
|
FreeMem(FCIDA, CIDASize);
|
|
FCIDA := nil;
|
|
Inc(Count, SizeOf(FCIDA.cidl));
|
|
Inc(Count, SizeOf(FCIDA.aoffset) * (APIDLList.Count));
|
|
for i := 0 to APIDLList.Count - 1 do
|
|
Inc(Count, PIDLMgr.PIDLSize( APIDLList[i]));
|
|
GetMem(FCIDA, Count);
|
|
Head := FCIDA;
|
|
{ Head points to the position of the first PIDL }
|
|
Inc(PChar(Head), SizeOf(FCIDA.cidl) + (SizeOf(FCIDA.aoffset) * APIDLList.Count));
|
|
{ Don't count the absolute parent PIDL }
|
|
FCIDA.cidl := APIDLList.Count - 1;
|
|
for i := 0 to APIDLList.Count - 1 do
|
|
begin
|
|
{ Set up the array index to point to the actual PIDL data }
|
|
FCIDA.aoffset[i] := LongWord(Head-PChar( CIDA));
|
|
PIDLLength := PIDLMgr.PIDLSize(APIDLList[i]);
|
|
Move(APIDLList[i]^, Head^, PIDLLength);
|
|
Inc(PChar(Head), PIDLLength);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
destructor TCommonShellIDList.Destroy;
|
|
begin
|
|
{ Free previously assigned CIDA }
|
|
if Assigned(FCIDA) then
|
|
FreeMem(FCIDA, CIDASize);
|
|
inherited;
|
|
end;
|
|
|
|
function TCommonShellIDList.GetCIDASize: integer;
|
|
var
|
|
Count: integer;
|
|
i: integer;
|
|
begin
|
|
Count := 0;
|
|
if Assigned(FCIDA) then
|
|
begin
|
|
Inc(Count, SizeOf( FCIDA.cidl));
|
|
Inc(Count, SizeOf( FCIDA.aoffset) * (PIDLCount + 1)); // Does't count [0]
|
|
Inc(Count, PIDLMgr.PIDLSize(InternalParentPIDL));
|
|
for i := 0 to PIDLCount - 1 do
|
|
Inc(Count, PIDLMgr.PIDLSize(InternalChildPIDL(i)));
|
|
end;
|
|
Result := Count;
|
|
end;
|
|
|
|
function TCommonShellIDList.GetFormatEtc: TFormatEtc;
|
|
begin
|
|
Result.cfFormat := CF_SHELLIDLIST;
|
|
Result.ptd := nil;
|
|
Result.dwAspect := DVASPECT_CONTENT;
|
|
Result.lindex := -1;
|
|
Result.tymed := TYMED_HGLOBAL;
|
|
end;
|
|
|
|
function TCommonShellIDList.InternalChildPIDL(Index: integer): PItemIDList;
|
|
{ Remember PIDLCount does not count index [0] where the Absolute Parent is }
|
|
begin
|
|
if Assigned(FCIDA) and (Index > -1) and (Index < PIDLCount) then
|
|
Result := PItemIDList( PChar(FCIDA) + PDWORD(PChar(@FCIDA^.aoffset)+sizeof(FCIDA^.aoffset[0])*(1+Index))^)
|
|
else
|
|
Result := nil
|
|
end;
|
|
|
|
function TCommonShellIDList.InternalParentPIDL: PItemIDList;
|
|
{ Remember PIDLCount does not count index [0] where the Absolute Parent is }
|
|
begin
|
|
if Assigned(FCIDA) then
|
|
Result := PItemIDList( PChar(FCIDA) + FCIDA^.aoffset[0])
|
|
else
|
|
Result := nil
|
|
end;
|
|
|
|
function TCommonShellIDList.LoadFromClipboard: Boolean;
|
|
var
|
|
Handle: THandle;
|
|
Ptr: PIDA;
|
|
begin
|
|
Result := True;
|
|
Handle := 0;
|
|
if Result then
|
|
begin
|
|
try
|
|
try
|
|
Handle := GetClipboardData(CF_SHELLIDLIST);
|
|
if Handle <> 0 then
|
|
begin
|
|
Ptr := GlobalLock(Handle);
|
|
if Assigned(Ptr) then
|
|
begin
|
|
CIDA := Ptr;
|
|
Result := True;
|
|
end;
|
|
end;
|
|
except
|
|
Result := False;
|
|
raise;
|
|
end;
|
|
finally
|
|
GlobalUnLock(Handle);
|
|
end;
|
|
end
|
|
end;
|
|
|
|
function TCommonShellIDList.LoadFromDataObject(DataObject: IDataObject): Boolean;
|
|
var
|
|
Ptr: PIDA;
|
|
StgMedium: TStgMedium;
|
|
begin
|
|
Result := False;
|
|
FillChar(StgMedium, SizeOf(StgMedium), #0);
|
|
if Succeeded(DataObject.GetData(GetFormatEtc, StgMedium)) then
|
|
try
|
|
Ptr := GlobalLock(StgMedium.hGlobal);
|
|
try
|
|
if Assigned(Ptr) then
|
|
begin
|
|
CIDA := Ptr;
|
|
Result := True;
|
|
end;
|
|
finally
|
|
GlobalUnLock(StgMedium.hGlobal);
|
|
end;
|
|
finally
|
|
ReleaseStgMedium(StgMedium)
|
|
end;
|
|
end;
|
|
|
|
function TCommonShellIDList.ParentPIDL: PItemIDList;
|
|
begin
|
|
Result := PIDLMgr.CopyPIDL( InternalParentPIDL)
|
|
end;
|
|
|
|
function TCommonShellIDList.PIDLCount: integer;
|
|
{ indexing is a bit weird. Index 0 is the Absolute Parent PIDL but it is not }
|
|
{ counted in the first byte of the structure. }
|
|
begin
|
|
if Assigned(FCIDA) then
|
|
Result := FCIDA^.cidl
|
|
else
|
|
Result := 0
|
|
end;
|
|
|
|
function TCommonShellIDList.RelativePIDL(Index: integer): PItemIDList;
|
|
{ Retrieves the single ItemID child by index }
|
|
begin
|
|
Result := PIDLMgr.CopyPIDL( InternalChildPIDL(Index))
|
|
end;
|
|
|
|
procedure TCommonShellIDList.RelativePIDLs(APIDLList: TCommonPIDLList);
|
|
{ Loads APIDLList with PIDL's stored in the CIDA. ReturnCopy flags if the }
|
|
{ contents will be the origionals or copies created by the PIDLMgr. }
|
|
var
|
|
i: integer;
|
|
begin
|
|
if Assigned(APIDLList) and Assigned(FCIDA) then
|
|
begin
|
|
APIDLList.CopyAdd( InternalParentPIDL);
|
|
for i := 0 to PIDLCount - 1 do
|
|
APIDLList.CopyAdd( InternalChildPIDL(i))
|
|
end;
|
|
end;
|
|
|
|
function TCommonShellIDList.SaveToClipboard: Boolean;
|
|
var
|
|
DataObject: IDataObject;
|
|
begin
|
|
Result := False;
|
|
DataObject := TCommonDataObject.Create;
|
|
if SaveToDataObject(DataObject) then
|
|
Result := Succeeded(OleSetClipboard(DataObject))
|
|
end;
|
|
|
|
function TCommonShellIDList.SaveToDataObject(DataObject: IDataObject): Boolean;
|
|
var
|
|
StgMedium: TStgMedium;
|
|
Ptr: PIDA;
|
|
begin
|
|
FillChar(StgMedium, SizeOf(StgMedium), #0);
|
|
|
|
StgMedium.hGlobal := GlobalAlloc(GPTR, GetCIDASize);
|
|
Ptr := GlobalLock(StgMedium.hGlobal);
|
|
try
|
|
StgMedium.tymed := TYMED_HGLOBAL;
|
|
CopyMemory(Ptr, CIDA, GetCIDASize);
|
|
Result := Succeeded(DataObject.SetData(GetFormatEtc, StgMedium, True))
|
|
finally
|
|
GlobalUnLock(StgMedium.hGlobal);
|
|
end;
|
|
end;
|
|
|
|
procedure TCommonShellIDList.SetCIDA(const Value: PIDA);
|
|
var
|
|
TempSize: integer;
|
|
begin
|
|
{ Free previously assigned CIDA }
|
|
if Assigned(FCIDA) then
|
|
begin
|
|
FreeMem(FCIDA, CIDASize);
|
|
FCIDA := nil;
|
|
end;
|
|
if Value <> nil then
|
|
begin
|
|
{ Temporally assign the passed PIDA to the object }
|
|
FCIDA := Value;
|
|
{ Get the size of the passed PIDA }
|
|
TempSize := CIDASize;
|
|
{ Get memory to make a copy of the passed PIDA }
|
|
GetMem(FCIDA, TempSize);
|
|
{ Copy the passed PIDA }
|
|
Move(Value^, FCIDA^, TempSize);
|
|
end;
|
|
end;
|
|
|
|
{ TCommonEnumFormatEtc }
|
|
|
|
function TCommonEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult;
|
|
// Creates a exact copy of the current object.
|
|
var
|
|
EnumFormatEtc: TCommonEnumFormatEtc;
|
|
begin
|
|
Result := S_OK; // Think positive
|
|
EnumFormatEtc := TCommonEnumFormatEtc.Create; // Does not increase COM reference
|
|
if Assigned(EnumFormatEtc) then
|
|
begin
|
|
SetLength(EnumFormatEtc.FFormats, Length(Formats));
|
|
// Make copy of Format info
|
|
Move(FFormats[0], EnumFormatEtc.FFormats[0], Length(Formats) * SizeOf(TFormatEtc));
|
|
EnumFormatEtc.InternalIndex := InternalIndex;
|
|
Enum := EnumFormatEtc as IEnumFormatEtc; // Sets COM reference to 1
|
|
end else
|
|
Result := E_UNEXPECTED
|
|
end;
|
|
|
|
constructor TCommonEnumFormatEtc.Create;
|
|
begin
|
|
inherited Create;
|
|
InternalIndex := 0;
|
|
end;
|
|
|
|
destructor TCommonEnumFormatEtc.Destroy;
|
|
begin
|
|
inherited;
|
|
end;
|
|
|
|
function TCommonEnumFormatEtc.Next(celt: Integer; out elt; pceltFetched: PLongint): HResult;
|
|
// Another EnumXXXX function. This function returns the number of objects
|
|
// requested by the caller in celt. The return buffer, elt, is a pointer to an}
|
|
// array of, in this case, TFormatEtc structures. The total number of
|
|
// structures returned is placed in pceltFetched. pceltFetched may be nil if
|
|
// celt is only asking for one structure at a time.
|
|
var
|
|
i: integer;
|
|
begin
|
|
if Assigned(Formats) then
|
|
begin
|
|
i := 0;
|
|
while (i < celt) and (InternalIndex < Length(Formats)) do
|
|
begin
|
|
TeltArray( elt)[i] := Formats[InternalIndex];
|
|
inc(i);
|
|
inc(FInternalIndex);
|
|
end; // while
|
|
if assigned(pceltFetched) then
|
|
pceltFetched^ := i;
|
|
if i = celt then
|
|
Result := S_OK
|
|
else
|
|
Result := S_FALSE
|
|
end else
|
|
Result := E_UNEXPECTED
|
|
end;
|
|
|
|
function TCommonEnumFormatEtc.Reset: HResult;
|
|
begin
|
|
InternalIndex := 0;
|
|
Result := S_OK
|
|
end;
|
|
|
|
function TCommonEnumFormatEtc.Skip(celt: Integer): HResult;
|
|
// Allows the caller to skip over unwanted TFormatEtc structures. Simply adds
|
|
// celt to the index as long as it does not skip past the last structure in
|
|
// the list.
|
|
begin
|
|
if Assigned(Formats) then
|
|
begin
|
|
if InternalIndex + celt < Length(Formats) then
|
|
begin
|
|
InternalIndex := InternalIndex + celt;
|
|
Result := S_OK
|
|
end else
|
|
Result := S_FALSE
|
|
end else
|
|
Result := E_UNEXPECTED
|
|
end;
|
|
|
|
procedure TCommonEnumFormatEtc.SetFormatLength(Size: Integer);
|
|
begin
|
|
SetLength(FFormats, Size)
|
|
end;
|
|
|
|
{ TCommonDataObject }
|
|
class function TCommonDataObject.NewInstance: TObject;
|
|
begin
|
|
Result := inherited NewInstance;
|
|
TCommonDataObject(Result).FRefCount := 1;
|
|
end;
|
|
|
|
|
|
function TCommonDataObject.AssignDragImage(Image: TBitmap;
|
|
HotSpot: TPoint; TransparentColor: TColor): Boolean;
|
|
//
|
|
// Stores the Bitmap in the IDataObject to support the IDragSourceHelper drag image
|
|
// in Win2K and above.
|
|
//
|
|
var
|
|
DragSourceHelper: IDragSourceHelper;
|
|
SHDragImage: TSHDragImage;
|
|
begin
|
|
Result := False;
|
|
// NT can't swallow this CoCreateInstance call
|
|
if not IsWinNT4 then
|
|
begin
|
|
if Succeeded(CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IID_IDragSourceHelper, DragSourceHelper)) then
|
|
begin
|
|
FillChar(SHDragImage, SizeOf(SHDragImage), #0);
|
|
|
|
SHDragImage.sizeDragImage.cx := Image.Width;
|
|
SHDragImage.sizeDragImage.cy := Image.Height;
|
|
SHDragImage.ptOffset := HotSpot;
|
|
SHDragImage.ColorRef := ColorToRGB(TransparentColor);
|
|
SHDragImage.hbmpDragImage := CopyImage(Image.Handle, IMAGE_BITMAP, Image.Width,
|
|
Image.Height, LR_COPYRETURNORG);
|
|
if SHDragImage.hbmpDragImage <> 0 then
|
|
if Succeeded(DragSourceHelper.InitializeFromBitmap(SHDragImage, Self as IDataObject)) then
|
|
Result := True
|
|
else
|
|
DeleteObject(SHDragImage.hbmpDragImage);
|
|
end
|
|
end
|
|
end;
|
|
|
|
function TCommonDataObject.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 CommonSupports(TestUnknown, IUnknown, Result) then
|
|
IUnknown(Result)._Release // Don't actually need it just need the pointer value
|
|
else
|
|
Result := TestUnknown
|
|
end else
|
|
Result := TestUnknown
|
|
end;
|
|
|
|
constructor TCommonDataObject.Create;
|
|
begin
|
|
inherited;
|
|
end;
|
|
|
|
function TCommonDataObject.DAdvise(const formatetc: TFormatEtc; advf: Integer;
|
|
const advSink: IAdviseSink; out dwConnection: Integer): HResult;
|
|
begin
|
|
if not Assigned(AdviseHolder) then
|
|
CreateDataAdviseHolder(FAdviseHolder);
|
|
if Assigned(FAdviseHolder) then
|
|
Result := AdviseHolder.Advise(Self as IDataObject, formatetc, advf, advSink, dwConnection)
|
|
else
|
|
Result := OLE_E_ADVISENOTSUPPORTED;
|
|
end;
|
|
|
|
destructor TCommonDataObject.Destroy;
|
|
begin
|
|
inherited;
|
|
end;
|
|
|
|
function TCommonDataObject.GetObj: TObject;
|
|
begin
|
|
Result := Self
|
|
end;
|
|
|
|
function TCommonDataObject.QueryInterface(const IID: TGUID; out Obj): HResult;
|
|
begin
|
|
if GetInterface(IID, Obj) then
|
|
Result := 0
|
|
else
|
|
Result := E_NOINTERFACE;
|
|
end;
|
|
|
|
function TCommonDataObject._AddRef: Integer;
|
|
begin
|
|
Result := InterlockedIncrement(FRefCount);
|
|
{$IFDEF GX_DEBUG}
|
|
SendDebug('TCommonDataObject: ' + IntToHex(Integer(Self), 8) + ' AddRef: Count = ' + IntToStr(FRefCount));
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function TCommonDataObject._Release: Integer;
|
|
begin
|
|
Result := InterlockedDecrement(FRefCount);
|
|
{$IFDEF GX_DEBUG}
|
|
SendDebug('TCommonDataObject: ' + IntToHex(Integer(Self), 8) + ' Release: Count = ' + IntToStr(FRefCount));
|
|
{$ENDIF}
|
|
if Result = 0 then
|
|
Destroy;
|
|
end;
|
|
|
|
procedure TCommonDataObject.AfterConstruction;
|
|
begin
|
|
// Release the constructor's implicit refcount
|
|
InterlockedDecrement(FRefCount);
|
|
end;
|
|
|
|
procedure TCommonDataObject.BeforeDestruction;
|
|
begin
|
|
// if RefCount <> 0 then
|
|
// Error(reInvalidPtr);
|
|
end;
|
|
|
|
procedure TCommonDataObject.DoGetCustomFormats(var Formats: TFormatEtcArray);
|
|
begin
|
|
|
|
end;
|
|
|
|
procedure TCommonDataObject.DoOnGetData(const FormatEtcIn: TFormatEtc;
|
|
var Medium: TStgMedium; var Handled: Boolean);
|
|
begin
|
|
if Assigned(FOnGetData) then
|
|
OnGetData(Self, FormatEtcIn, Medium, Handled);
|
|
end;
|
|
|
|
procedure TCommonDataObject.DoOnQueryGetData(
|
|
const FormatEtcIn: TFormatEtc; var FormatAvailable: Boolean; var Handled: Boolean);
|
|
begin
|
|
if Assigned(FOnQueryGetData) then
|
|
OnQueryGetData(Self, FormatEtcIn, FormatAvailable, Handled);
|
|
end;
|
|
|
|
function TCommonDataObject.DUnadvise(dwConnection: Integer): HResult;
|
|
begin
|
|
if Assigned(AdviseHolder) then
|
|
Result := AdviseHolder.Unadvise(dwConnection)
|
|
else
|
|
Result := OLE_E_ADVISENOTSUPPORTED;
|
|
end;
|
|
|
|
function TCommonDataObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult;
|
|
begin
|
|
if Assigned(AdviseHolder) then
|
|
Result := AdviseHolder.EnumAdvise(enumAdvise)
|
|
else
|
|
Result := OLE_E_ADVISENOTSUPPORTED;
|
|
end;
|
|
|
|
function TCommonDataObject.EnumFormatEtc(dwDirection: Integer;
|
|
out enumFormatEtc: IEnumFormatEtc): HResult;
|
|
// Called when DoDragDrop wants to know what clipboard formats are supported
|
|
// by Enumerating the TFormatEtc array through an IEnumFormatEtc object.
|
|
var
|
|
LocalEnumFormatEtc: TCommonEnumFormatEtc;
|
|
i: integer;
|
|
begin
|
|
// Always return an object even if it is empty
|
|
LocalEnumFormatEtc := TCommonEnumFormatEtc.Create;
|
|
// Get the reference count in sync
|
|
enumFormatEtc := LocalEnumFormatEtc as IEnumFormatEtc;
|
|
{ if Assigned(Formats) then
|
|
begin }
|
|
Result := S_OK;
|
|
if dwDirection = DATADIR_GET then
|
|
begin
|
|
// Copy the internal supported Formats for the EnumFormatEtc
|
|
SetLength(LocalEnumFormatEtc.FFormats, Length(Formats));
|
|
for i := 0 to Length(Formats) - 1 do
|
|
LocalEnumFormatEtc.Formats[i] := Formats[i].FormatEtc;
|
|
|
|
// Now copy any custom formats
|
|
DoGetCustomFormats(LocalEnumFormatEtc.FFormats);
|
|
|
|
if not Assigned(enumFormatEtc) then
|
|
Result := E_OUTOFMEMORY
|
|
end else
|
|
begin
|
|
enumFormatEtc := nil;
|
|
Result := E_NOTIMPL;
|
|
end;
|
|
{ end else
|
|
begin
|
|
if dwDirection = DATADIR_GET then
|
|
Result := S_OK
|
|
else
|
|
Result := E_NOTIMPL
|
|
end }
|
|
end;
|
|
|
|
function TCommonDataObject.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 = FormatEtc2.tymed)
|
|
end;
|
|
|
|
function TCommonDataObject.FindFormatEtc(TestFormatEtc: TFormatEtc): integer;
|
|
var
|
|
i: integer;
|
|
Found: Boolean;
|
|
begin
|
|
i := 0;
|
|
Found := False;
|
|
Result := -1;
|
|
while (i < Length(FFormats)) and not Found do
|
|
begin
|
|
Found := EqualFormatEtc(Formats[i].FormatEtc, TestFormatEtc);
|
|
if Found then
|
|
Result := i;
|
|
Inc(i);
|
|
end
|
|
end;
|
|
|
|
function TCommonDataObject.GetCanonicalFormatEtc(const formatetc: TFormatEtc;
|
|
out formatetcOut: TFormatEtc): HResult;
|
|
// Since we do not have two TFormatEtcs that return the same type of data we can
|
|
// ingore this function. It is only for TFormatEtc structures that will return
|
|
// the exact same data if each is called. This could happen if the data is
|
|
// target dependant and the target can handle both types of data. This keeps
|
|
// the target from asking for redundant information.
|
|
begin
|
|
formatetcOut.ptd := nil;
|
|
Result := E_NOTIMPL;
|
|
end;
|
|
|
|
function TCommonDataObject.GetData(const FormatEtcIn: TFormatEtc;
|
|
out Medium: TStgMedium): HResult;
|
|
// This is the workhorse of the functions. It looks at the clipboard format
|
|
// the IDropTarget wants, makes sure we can support it. If supported then see
|
|
// if it is owned by the object or the program will supply the data.
|
|
var
|
|
Handled: Boolean;
|
|
begin
|
|
Result := E_UNEXPECTED;
|
|
Handled := False;
|
|
DoOnGetData(FormatEtcIn, Medium, Handled);
|
|
if not Handled then
|
|
begin
|
|
if Assigned(Formats) then
|
|
begin
|
|
{ Do we support this type of Data? }
|
|
Result := QueryGetData(FormatEtcIn);
|
|
if Result = S_OK then
|
|
begin
|
|
// If the data is owned by the IDataObject just retrieve and return it.
|
|
if RetrieveOwnedStgMedium(FormatEtcIn, Medium) = E_INVALIDARG then
|
|
{ This data is defined by the Object Inspector or a custom format need to }
|
|
{ Retrive it from the DragSourceManager }
|
|
if not GetUserData(FormatEtcIn, Medium) then
|
|
Result := E_UNEXPECTED
|
|
end
|
|
end
|
|
end else
|
|
Result := S_OK
|
|
end;
|
|
|
|
function TCommonDataObject.GetDataHere(const formatetc: TFormatEtc;
|
|
out medium: TStgMedium): HResult;
|
|
begin
|
|
Result := E_NOTIMPL;
|
|
end;
|
|
|
|
function TCommonDataObject.GetUserData(Format: TFormatEtc; var StgMedium: TStgMedium): Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TCommonDataObject.HGlobalClone(HGlobal: THandle): THandle;
|
|
// Returns a global memory block that is a copy of the passed memory block.
|
|
var
|
|
Size: LongWord;
|
|
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 TCommonDataObject.LoadGlobalBlock(Format: TClipFormat;
|
|
var MemoryBlock: Pointer): Boolean;
|
|
var
|
|
FormatEtc: TFormatEtc;
|
|
StgMedium: TStgMedium;
|
|
GlobalObject: Pointer;
|
|
begin
|
|
Result := False;
|
|
|
|
FormatEtc.cfFormat := Format;
|
|
FormatEtc.ptd := nil;
|
|
FormatEtc.dwAspect := DVASPECT_CONTENT;
|
|
FormatEtc.lindex := -1;
|
|
FormatEtc.tymed := TYMED_HGLOBAL;
|
|
|
|
if Succeeded(QueryGetData(FormatEtc)) and Succeeded(GetData(FormatEtc, StgMedium)) then
|
|
begin
|
|
MemoryBlock := AllocMem( GlobalSize(StgMedium.hGlobal));
|
|
GlobalObject := GlobalLock(StgMedium.hGlobal);
|
|
try
|
|
if Assigned(MemoryBlock) and Assigned(GlobalObject) then
|
|
begin
|
|
Move(GlobalObject^, MemoryBlock^, GlobalSize(StgMedium.hGlobal));
|
|
end
|
|
finally
|
|
GlobalUnLock(StgMedium.hGlobal);
|
|
end
|
|
end;
|
|
end;
|
|
|
|
function TCommonDataObject.QueryGetData(const formatetc: TFormatEtc): HResult;
|
|
// This function allows the IDragTarget to see if we can possibly support some
|
|
// type of data transfer.
|
|
var
|
|
i: integer;
|
|
FormatAvailable, Handled: Boolean;
|
|
begin
|
|
Handled := False;
|
|
FormatAvailable := False;
|
|
DoOnQueryGetData(FormatEtc, FormatAvailable, Handled);
|
|
if Handled then
|
|
begin
|
|
if FormatAvailable then
|
|
Result := S_OK
|
|
else
|
|
Result := DV_E_FORMATETC
|
|
end else
|
|
begin
|
|
if not FormatAvailable then
|
|
begin
|
|
if Assigned(Formats) then
|
|
begin
|
|
i := 0;
|
|
Result := DV_E_FORMATETC;
|
|
while (i < Length(Formats)) and (Result = DV_E_FORMATETC) do
|
|
begin
|
|
if Formats[i].FormatEtc.cfFormat = formatetc.cfFormat then
|
|
begin
|
|
if (Formats[i].FormatEtc.dwAspect = formatetc.dwAspect) then
|
|
begin
|
|
if (Formats[i].FormatEtc.tymed and formatetc.tymed <> 0) then
|
|
Result := S_OK
|
|
else
|
|
Result := DV_E_TYMED;
|
|
end else
|
|
Result := DV_E_DVASPECT;
|
|
end else
|
|
Result := DV_E_FORMATETC;
|
|
Inc(i)
|
|
end
|
|
end else
|
|
Result := E_UNEXPECTED;
|
|
end else
|
|
Result := S_OK
|
|
end
|
|
end;
|
|
|
|
function TCommonDataObject.RetrieveOwnedStgMedium(Format: TFormatEtc; var StgMedium: TStgMedium): HRESULT;
|
|
var
|
|
i: integer;
|
|
begin
|
|
Result := E_INVALIDARG;
|
|
i := FindFormatEtc(Format);
|
|
if (i > -1) and Formats[i].OwnedByDataObject then
|
|
Result := StgMediumIncRef(Formats[i].StgMedium, StgMedium, False)
|
|
end;
|
|
|
|
function TCommonDataObject.SaveGlobalBlock(Format: TClipFormat;
|
|
MemoryBlock: Pointer; MemoryBlockSize: integer): Boolean;
|
|
var
|
|
FormatEtc: TFormatEtc;
|
|
StgMedium: TStgMedium;
|
|
GlobalObject: Pointer;
|
|
begin
|
|
FormatEtc.cfFormat := Format;
|
|
FormatEtc.ptd := nil;
|
|
FormatEtc.dwAspect := DVASPECT_CONTENT;
|
|
FormatEtc.lindex := -1;
|
|
FormatEtc.tymed := TYMED_HGLOBAL;
|
|
|
|
StgMedium.tymed := TYMED_HGLOBAL;
|
|
StgMedium.unkForRelease := nil;
|
|
StgMedium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, MemoryBlockSize);
|
|
GlobalObject := GlobalLock(StgMedium.hGlobal);
|
|
try
|
|
try
|
|
Move(MemoryBlock^, GlobalObject^, MemoryBlockSize);
|
|
Result := Succeeded( SetData(FormatEtc, StgMedium, True))
|
|
except
|
|
Result := False;
|
|
end
|
|
finally
|
|
GlobalUnLock(StgMedium.hGlobal);
|
|
end
|
|
end;
|
|
|
|
function TCommonDataObject.SetData(const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult;
|
|
// Allows dynamic adding to the IDataObject during its existance. Most noteably
|
|
// it is used to implement IDropSourceHelper in win2k
|
|
var
|
|
Index: integer;
|
|
begin
|
|
// See if we already have a format of that type available.
|
|
Index := FindFormatEtc(FormatEtc);
|
|
if Index > - 1 then
|
|
begin
|
|
// Yes we already have that format type stored. Just use the TCommonClipboardFormat
|
|
// in the List after releasing the data
|
|
ReleaseStgMedium(Formats[Index].StgMedium);
|
|
FillChar(Formats[Index].StgMedium, SizeOf(Formats[Index].StgMedium), #0);
|
|
end else
|
|
begin
|
|
// It is a new format so create a new TDataObjectInfo record and store it in
|
|
// the Format array
|
|
SetLength(FFormats, Length(Formats) + 1);
|
|
Formats[Length(Formats) - 1].FormatEtc := FormatEtc;
|
|
Index := Length(Formats) - 1;
|
|
end;
|
|
// The data is owned by the TCommonClipboardFormat object
|
|
Formats[Index].OwnedByDataObject := True;
|
|
|
|
if fRelease then
|
|
begin
|
|
// We are simply being given the data and we take control of it.
|
|
Formats[Index].StgMedium := Medium;
|
|
Result := S_OK
|
|
end else
|
|
// We need to reference count or copy the data and keep our own references
|
|
// to it.
|
|
Result := StgMediumIncRef(Medium, Formats[Index].StgMedium, True);
|
|
|
|
// Can get a circular reference if the client calls GetData then calls
|
|
// SetData with the same StgMedium. Because the unkForRelease and 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(Formats[Index].StgMedium.unkForRelease) then
|
|
begin
|
|
if CanonicalIUnknown(Self) =
|
|
CanonicalIUnknown(IUnknown( Formats[Index].StgMedium.unkForRelease)) then
|
|
begin
|
|
IUnknown( Formats[Index].StgMedium.unkForRelease)._Release;
|
|
Formats[Index].StgMedium.unkForRelease := nil
|
|
end;
|
|
end;
|
|
// Tell all registered advice sinks about the data change.
|
|
if Assigned(AdviseHolder) then
|
|
AdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0);
|
|
end;
|
|
|
|
function TCommonDataObject.StgMediumIncRef(const InStgMedium: TStgMedium;
|
|
var OutStgMedium: TStgMedium; CopyInMedium: Boolean): HRESULT;
|
|
// This function increases the reference count of the passed StorageMedium in a
|
|
// variety of ways depending on the value of CopyInMedium.
|
|
// InStgMedium is the data that is requested a copy of, 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.
|
|
begin
|
|
Result := S_OK;
|
|
// Simply copy all fields to start with.
|
|
OutStgMedium := InStgMedium;
|
|
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 previoiusly saved
|
|
OutStgMedium.unkForRelease := Pointer(Self as IDataObject) // Does increase RefCount
|
|
end;
|
|
TYMED_FILE:
|
|
begin
|
|
if CopyInMedium then
|
|
begin
|
|
OutStgMedium.lpszFileName := CoTaskMemAlloc(lstrLenW(InStgMedium.lpszFileName));
|
|
MoveMemory(PWideChar(OutStgMedium.lpszFileName), PWideChar(InStgMedium.lpszFileName), lstrlenW(InStgMedium.lpszFileName) * 2);
|
|
end else
|
|
OutStgMedium.unkForRelease := Pointer(Self as IDataObject) // Does increase RefCount
|
|
end;
|
|
TYMED_ISTREAM:
|
|
// Simply increase the reference so the stream object
|
|
// Note here stm is a pointer to the auto reference counting won't work and
|
|
// we have to call _AddRef explicitly
|
|
IUnknown( OutStgMedium.stm)._AddRef;
|
|
TYMED_ISTORAGE:
|
|
// Simply increase the reference so the storage object
|
|
// Note here stm is a pointer to the auto reference counting won't work and
|
|
// we have to call _AddRef explicitly
|
|
IUnknown( OutStgMedium.stg)._AddRef;
|
|
TYMED_GDI:
|
|
if not CopyInMedium then
|
|
// Don't generate a copy just use ourselves and the copy previoiusly saved data
|
|
OutStgMedium.unkForRelease := Pointer(Self as IDataObject) // 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
|
|
OutStgMedium.unkForRelease := Pointer(Self as IDataObject) // 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 copy previoiusly saved data }
|
|
OutStgMedium.unkForRelease := Pointer(Self as IDataObject) // 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;
|
|
|
|
// I still have to do this. The Compiler will call _Release on the above Self as IDataObject
|
|
// casts which is not what is necessary. The DataObject is released correctly.
|
|
if Assigned(OutStgMedium.unkForRelease) and (Result = S_OK) then
|
|
IUnknown(OutStgMedium.unkForRelease)._AddRef
|
|
end;
|
|
|
|
{ TFileGroupDescriptorA }
|
|
|
|
procedure TFileGroupDescriptorA.AddFileDescriptor(
|
|
FileDescriptor: TFileDescriptorA);
|
|
begin
|
|
SetLength(FFileDescriptors, Length(FFileDescriptors) + 1);
|
|
FFileDescriptors[Length(FFileDescriptors) - 1] := FileDescriptor;
|
|
end;
|
|
|
|
procedure TFileGroupDescriptorA.DeleteFileDescriptor(Index: integer);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := Index to Length(FFileDescriptors) - 1 do
|
|
FileDescriptor[i] := FileDescriptor[i+1];
|
|
SetLength(FFileDescriptors, Length(FFileDescriptors) - 1);
|
|
end;
|
|
|
|
function TFileGroupDescriptorA.FillDescriptor(FileName: string): TFileDescriptorA;
|
|
begin
|
|
FillChar(Result, SizeOf(Result), #0);
|
|
StrCopy(Result.cFileName, PChar(FileName));
|
|
end;
|
|
|
|
function TFileGroupDescriptorA.GetDescriptorCount: Integer;
|
|
begin
|
|
Result := Length(FFileDescriptors)
|
|
end;
|
|
|
|
function TFileGroupDescriptorA.GetFileDescriptorA(Index: Integer): TFileDescriptorA;
|
|
begin
|
|
FillChar(Result, SizeOf(Result), #0);
|
|
if (Index > -1) and (Index < Length(FFileDescriptors)) then
|
|
Result := FFileDescriptors[Index]
|
|
end;
|
|
|
|
function TFileGroupDescriptorA.GetFileStream(const DataObject: IDataObject;
|
|
FileIndex: Integer): TStream;
|
|
var
|
|
Format: TFormatEtc;
|
|
Medium: TStgMedium;
|
|
begin
|
|
if Assigned(Stream) then
|
|
FreeAndNil(FStream);
|
|
|
|
if Assigned(DataObject) and (FileIndex > 0) and (FileIndex < DescriptorCount) then
|
|
begin
|
|
Format.cfFormat := CF_FILECONTENTS;
|
|
Format.ptd := nil;
|
|
Format.dwAspect := DVASPECT_CONTENT;
|
|
Format.lindex := FileIndex;
|
|
Format.tymed := TYMED_ISTREAM;
|
|
if Succeeded(DataObject.GetData(Format, Medium)) then
|
|
begin
|
|
Stream := TOLEStream.Create(IStream(Medium.stm));
|
|
ReleaseStgMedium(Medium);
|
|
end
|
|
end;
|
|
Result := Stream;
|
|
end;
|
|
|
|
function TFileGroupDescriptorA.GetFormatEtc: TFormatEtc;
|
|
begin
|
|
Result := FileDescriptorAFormat
|
|
end;
|
|
|
|
procedure TFileGroupDescriptorA.LoadFileGroupDestriptor(FileGroupDiscriptor: PFileGroupDescriptorA);
|
|
var
|
|
i: Cardinal;
|
|
begin
|
|
if Assigned(FileGroupDiscriptor) then
|
|
begin
|
|
SetLength(FFileDescriptors, FileGroupDiscriptor.cItems);
|
|
for i := 0 to FileGroupDiscriptor.cItems - 1 do
|
|
begin
|
|
FFileDescriptors[i] := FileGroupDiscriptor.fgd[i]
|
|
end
|
|
end else
|
|
FFileDescriptors := nil;
|
|
end;
|
|
|
|
function TFileGroupDescriptorA.LoadFromClipboard: Boolean;
|
|
var
|
|
DataObject: IDataObject;
|
|
begin
|
|
Result := False;
|
|
if Succeeded(OleGetClipboard(DataObject)) then
|
|
Result := LoadFromDataObject(DataObject);
|
|
end;
|
|
|
|
function TFileGroupDescriptorA.LoadFromDataObject(DataObject: IDataObject): Boolean;
|
|
var
|
|
GroupDescriptor: PFileGroupDescriptorA;
|
|
Medium: TStgMedium;
|
|
i: Integer;
|
|
begin
|
|
Result := False;
|
|
if Succeeded(DataObject.GetData(GetFormatEtc, Medium)) then
|
|
begin
|
|
GroupDescriptor := GlobalLock(Medium.hGlobal);
|
|
try
|
|
for i := 0 to GroupDescriptor^.cItems - 1 do
|
|
AddFileDescriptor(GroupDescriptor^.fgd[i])
|
|
finally
|
|
GlobalUnlock(Medium.hGlobal);
|
|
ReleaseStgMedium(Medium);
|
|
Result := True
|
|
end
|
|
end
|
|
end;
|
|
|
|
function TFileGroupDescriptorA.SaveToClipboard: Boolean;
|
|
var
|
|
DataObject: IDataObject;
|
|
begin
|
|
Result := False;
|
|
DataObject := TCommonDataObject.Create;
|
|
if SaveToDataObject(DataObject) then
|
|
Result := Succeeded(OleSetClipboard(DataObject))
|
|
end;
|
|
|
|
function TFileGroupDescriptorA.SaveToDataObject(DataObject: IDataObject): Boolean;
|
|
var
|
|
Mem: THandle;
|
|
GroupDescriptor: PFileGroupDescriptorA;
|
|
Medium: TStgMedium;
|
|
Format: TFormatEtc;
|
|
begin
|
|
Result := False;
|
|
if Assigned(DataObject) and (DescriptorCount > 0) then
|
|
begin
|
|
Mem := GlobalAlloc(GHND, DescriptorCount * SizeOf(TFileDescriptorA) + SizeOf(GroupDescriptor.cItems));
|
|
GroupDescriptor := GlobalLock(Mem);
|
|
try
|
|
GroupDescriptor.cItems := DescriptorCount;
|
|
CopyMemory(@GroupDescriptor^.fgd[0], @FFileDescriptors[0], DescriptorCount * SizeOf(TFileDescriptorA));
|
|
finally
|
|
GlobalUnlock(Mem)
|
|
end;
|
|
FillChar(Medium, SizeOf(Medium), #0);
|
|
Medium.tymed := TYMED_HGLOBAL;
|
|
Medium.hGlobal := Mem;
|
|
|
|
DataObject.SetData(GetFormatEtc, Medium, True);
|
|
|
|
Medium.tymed := TYMED_ISTREAM;
|
|
Medium.stm := nil;
|
|
|
|
Format.cfFormat := CF_FILECONTENTS;
|
|
Format.ptd := nil;
|
|
Format.dwAspect := DVASPECT_CONTENT;
|
|
Format.lindex := -1;
|
|
Format.tymed := TYMED_ISTREAM;
|
|
DataObject.SetData(Format, Medium, True);
|
|
end
|
|
end;
|
|
|
|
procedure TFileGroupDescriptorA.SetFileDescriptor(Index: Integer; const Value: TFileDescriptorA);
|
|
begin
|
|
if (Index > -1) and (Index < Length(FFileDescriptors)) then
|
|
FFileDescriptors[Index] := Value
|
|
end;
|
|
|
|
{ TFileGroupDescriptorW }
|
|
|
|
procedure TFileGroupDescriptorW.AddFileDescriptor(
|
|
FileDescriptor: TFileDescriptorW);
|
|
begin
|
|
SetLength(FFileDescriptors, Length(FFileDescriptors) + 1);
|
|
FFileDescriptors[Length(FFileDescriptors) - 1] := FileDescriptor;
|
|
end;
|
|
|
|
procedure TFileGroupDescriptorW.DeleteFileDescriptor(Index: integer);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := Index to Length(FFileDescriptors) - 1 do
|
|
FileDescriptor[i] := FileDescriptor[i+1];
|
|
SetLength(FFileDescriptors, Length(FFileDescriptors) - 1);
|
|
end;
|
|
|
|
function TFileGroupDescriptorW.FillDescriptor(FileName: WideString): TFileDescriptorW;
|
|
begin
|
|
FillChar(Result, SizeOf(Result), #0);
|
|
StrCopyW(Result.cFileName, PWideChar(FileName));
|
|
end;
|
|
|
|
function TFileGroupDescriptorW.GetDescriptorCount: Integer;
|
|
begin
|
|
Result := Length(FFileDescriptors)
|
|
end;
|
|
|
|
function TFileGroupDescriptorW.GetFileDescriptorW(Index: Integer): TFileDescriptorW;
|
|
begin
|
|
FillChar(Result, SizeOf(Result), #0);
|
|
if (Index > -1) and (Index < Length(FFileDescriptors)) then
|
|
Result := FFileDescriptors[Index]
|
|
end;
|
|
|
|
function TFileGroupDescriptorW.GetFileStream(const DataObject: IDataObject; FileIndex: Integer): TStream;
|
|
var
|
|
Format: TFormatEtc;
|
|
Medium: TStgMedium;
|
|
begin
|
|
if Assigned(Stream) then
|
|
FreeAndNil(FStream);
|
|
|
|
if Assigned(DataObject) and (FileIndex > -1) and (FileIndex < DescriptorCount) then
|
|
begin
|
|
Format.cfFormat := CF_FILECONTENTS;
|
|
Format.ptd := nil;
|
|
Format.dwAspect := DVASPECT_CONTENT;
|
|
Format.lindex := FileIndex;
|
|
Format.tymed := TYMED_ISTREAM;
|
|
if Succeeded(DataObject.GetData(Format, Medium)) then
|
|
begin
|
|
Stream := TOLEStream.Create(IStream(Medium.stm));
|
|
ReleaseStgMedium(Medium);
|
|
end;
|
|
end;
|
|
Result := Stream;
|
|
end;
|
|
|
|
function TFileGroupDescriptorW.GetFormatEtc: TFormatEtc;
|
|
begin
|
|
Result := FileDescriptorWFormat
|
|
end;
|
|
|
|
procedure TFileGroupDescriptorW.LoadFileGroupDestriptor(FileGroupDiscriptor: PFileGroupDescriptorW);
|
|
var
|
|
i: Cardinal;
|
|
begin
|
|
if Assigned(FileGroupDiscriptor) then
|
|
begin
|
|
SetLength(FFileDescriptors, FileGroupDiscriptor.cItems);
|
|
for i := 0 to FileGroupDiscriptor.cItems - 1 do
|
|
begin
|
|
FFileDescriptors[i] := FileGroupDiscriptor.fgd[i]
|
|
end
|
|
end else
|
|
FFileDescriptors := nil;
|
|
end;
|
|
|
|
function TFileGroupDescriptorW.LoadFromClipboard: Boolean;
|
|
var
|
|
DataObject: IDataObject;
|
|
begin
|
|
Result := False;
|
|
if Succeeded(OleGetClipboard(DataObject)) then
|
|
Result := LoadFromDataObject(DataObject);
|
|
end;
|
|
|
|
function TFileGroupDescriptorW.LoadFromDataObject(DataObject: IDataObject): Boolean;
|
|
var
|
|
GroupDescriptor: PFileGroupDescriptorW;
|
|
Medium: TStgMedium;
|
|
i: Integer;
|
|
begin
|
|
Result := False;
|
|
if Succeeded(DataObject.GetData(GetFormatEtc, Medium)) then
|
|
begin
|
|
GroupDescriptor := GlobalLock(Medium.hGlobal);
|
|
try
|
|
for i := 0 to GroupDescriptor^.cItems - 1 do
|
|
AddFileDescriptor(GroupDescriptor^.fgd[i])
|
|
finally
|
|
GlobalUnlock(Medium.hGlobal);
|
|
ReleaseStgMedium(Medium);
|
|
Result := True;
|
|
end
|
|
end
|
|
end;
|
|
|
|
function TFileGroupDescriptorW.SaveToClipboard: Boolean;
|
|
var
|
|
DataObject: IDataObject;
|
|
begin
|
|
Result := False;
|
|
DataObject := TCommonDataObject.Create;
|
|
if SaveToDataObject(DataObject) then
|
|
Result := Succeeded(OleSetClipboard(DataObject))
|
|
end;
|
|
|
|
function TFileGroupDescriptorW.SaveToDataObject(DataObject: IDataObject): Boolean;
|
|
var
|
|
Mem: THandle;
|
|
GroupDescriptor: PFileGroupDescriptorW;
|
|
Medium: TStgMedium;
|
|
Format: TFormatEtc;
|
|
begin
|
|
Result := False;
|
|
if Assigned(DataObject) and (DescriptorCount > 0) then
|
|
begin
|
|
Mem := GlobalAlloc(GHND, DescriptorCount * SizeOf(TFileDescriptorW) + SizeOf(GroupDescriptor.cItems));
|
|
GroupDescriptor := GlobalLock(Mem);
|
|
try
|
|
GroupDescriptor.cItems := DescriptorCount;
|
|
CopyMemory(@GroupDescriptor^.fgd[0], @FFileDescriptors[0], DescriptorCount * SizeOf(TFileDescriptorW));
|
|
finally
|
|
GlobalUnlock(Mem)
|
|
end;
|
|
FillChar(Medium, SizeOf(Medium), #0);
|
|
Medium.tymed := TYMED_HGLOBAL;
|
|
Medium.hGlobal := Mem;
|
|
|
|
DataObject.SetData(GetFormatEtc, Medium, True);
|
|
|
|
Medium.tymed := TYMED_ISTREAM;
|
|
Medium.stm := nil;
|
|
|
|
Format.cfFormat := CF_FILECONTENTS;
|
|
Format.ptd := nil;
|
|
Format.dwAspect := DVASPECT_CONTENT;
|
|
Format.lindex := -1;
|
|
Format.tymed := TYMED_ISTREAM;
|
|
DataObject.SetData(Format, Medium, True);
|
|
end
|
|
end;
|
|
|
|
procedure TFileGroupDescriptorW.SetFileDescriptor(Index: Integer; const Value: TFileDescriptorW);
|
|
begin
|
|
if (Index > -1) and (Index < Length(FFileDescriptors)) then
|
|
FFileDescriptors[Index] := Value
|
|
end;
|
|
|
|
{ TCommonInShellDragLoop }
|
|
function TCommonInShellDragLoop.GetFormatEtc: TFormatEtc;
|
|
begin
|
|
Result.cfFormat := CF_INDRAGLOOP;
|
|
Result.ptd := nil;
|
|
Result.dwAspect := DVASPECT_CONTENT;
|
|
Result.lindex := -1;
|
|
Result.tymed := TYMED_HGLOBAL
|
|
end;
|
|
|
|
function TCommonInShellDragLoop.LoadFromDataObject(DataObject: IDataObject): Boolean;
|
|
var
|
|
StgMedium: TStgMedium;
|
|
DataPtr: PCardinal;
|
|
begin
|
|
Result := False;
|
|
FillChar(StgMedium, SizeOf(StgMedium), #0);
|
|
|
|
if Succeeded(DataObject.GetData(GetFormatEtc, StgMedium)) then
|
|
try
|
|
DataPtr := GlobalLock(StgMedium.hGlobal);
|
|
try
|
|
if Assigned(DataPtr) then
|
|
begin
|
|
Data := DataPtr^;
|
|
Result := True;
|
|
end;
|
|
finally
|
|
GlobalUnLock(StgMedium.hGlobal);
|
|
end
|
|
finally
|
|
ReleaseStgMedium(StgMedium)
|
|
end
|
|
end;
|
|
|
|
function TCommonInShellDragLoop.SaveToDataObject(DataObject: IDataObject): Boolean;
|
|
var
|
|
StgMedium: TStgMedium;
|
|
Ptr: PCardinal;
|
|
begin
|
|
FillChar(StgMedium, SizeOf(StgMedium), #0);
|
|
StgMedium.hGlobal := GlobalAlloc(GPTR, SIZE_SHELLDRAGLOOPDATA);
|
|
Ptr := GlobalLock(StgMedium.hGlobal);
|
|
try
|
|
StgMedium.tymed := TYMED_HGLOBAL;
|
|
Ptr^ := FData;
|
|
Result := Succeeded(DataObject.SetData(GetFormatEtc, StgMedium, True))
|
|
finally
|
|
GlobalUnLock(StgMedium.hGlobal);
|
|
end
|
|
end;
|
|
|
|
initialization
|
|
CF_SHELLIDLIST := RegisterClipboardFormat(CFSTR_SHELLIDLIST);
|
|
CF_LOGICALPERFORMEDDROPEFFECT := RegisterClipboardFormat(CFSTR_LOGICALPERFORMEDDROPEFFECT);
|
|
CF_PREFERREDDROPEFFECT := RegisterClipboardFormat(CFSTR_PREFERREDDROPEFFECT);
|
|
CF_PERFORMEDDROPEFFECT := RegisterClipboardFormat(CFSTR_PERFORMEDDROPEFFECT);
|
|
CF_PASTESUCCEEDED := RegisterClipboardFormat(CFSTR_PASTESUCCEEDED);
|
|
CF_INDRAGLOOP := RegisterClipboardFormat(CFSTR_INDRAGLOOP);
|
|
CF_SHELLIDLISTOFFSET := RegisterClipboardFormat(CFSTR_SHELLIDLISTOFFSET);
|
|
CF_FILECONTENTS := RegisterClipboardFormat(CFSTR_FILECONTENTS);
|
|
CF_FILEDESCRIPTORA := RegisterClipboardFormat(CFSTR_FILEDESCRIPTORA);
|
|
CF_FILEDESCRIPTORW := RegisterClipboardFormat(CFSTR_FILEDESCRIPTORW);
|
|
PIDLMgr := TCommonPIDLManager.Create;
|
|
|
|
finalization
|
|
PIDLMgr.Free;
|
|
|
|
end.
|