unit DragDrop;
// -----------------------------------------------------------------------------
// Project: Drag and Drop Component Suite
// Module: DragDrop
// Description: Implements base classes and utility functions.
// Version: 4.0
// Date: 18-MAY-2001
// Target: Win32, Delphi 5-6
// Authors: Anders Melander, anders@melander.dk, http://www.melander.dk
// Copyright © 1997-2001 Angus Johnson & Anders Melander
// -----------------------------------------------------------------------------
// TODO -oanme -cPortability : Replace all public use of HWND with THandle. BCB's HWND <> Delphi's HWND.
{$include DragDrop.inc}
interface
uses
Classes,
Windows,
ActiveX;
{$IFDEF BCB}
{$HPPEMIT '#ifndef NO_WIN32_LEAN_AND_MEAN'}
{$HPPEMIT '"Error: The NO_WIN32_LEAN_AND_MEAN symbol must be defined in your projects conditional defines"'}
{$HPPEMIT '#endif'}
{$ENDIF}
const
DROPEFFECT_NONE = ActiveX.DROPEFFECT_NONE;
DROPEFFECT_COPY = ActiveX.DROPEFFECT_COPY;
DROPEFFECT_MOVE = ActiveX.DROPEFFECT_MOVE;
DROPEFFECT_LINK = ActiveX.DROPEFFECT_LINK;
DROPEFFECT_SCROLL = ActiveX.DROPEFFECT_SCROLL;
type
// TDragType enumerates the three possible drag/drop operations.
TDragType = (dtCopy, dtMove, dtLink);
TDragTypes = set of TDragType;
type
// TDataDirection is used by the clipboard format registration to specify
// if the clipboard format should be listed in get (read) format enumerations,
// set (write) format enumerations or both.
// ddRead : Destination (IDropTarget) can read data from IDataObject.
// ddWrite : Destination (IDropTarget) can write data to IDataObject.
TDataDirection = (ddRead, ddWrite);
TDataDirections = set of TDataDirection;
const
ddReadWrite = [ddRead, ddWrite];
type
// TConversionScope is used by the clipboard format registration to specify
// if a clipboard format conversion is supported by the drop source, the drop
// target or both.
// ddSource : Conversion is valid for drop source (IDropSource).
// ddTarget : Conversion is valid for drop target (IDropTarget).
TConversionScope = (csSource, csTarget);
TConversionScopes = set of TConversionScope;
const
csSourceTarget = [csSource, csTarget];
// C++ Builder's declaration of IEnumFORMATETC is incorrect, so we must generate
// the typedef for C++ Builder.
{$IFDEF BCB}
{$HPPEMIT 'typedef System::DelphiInterface<IEnumFORMATETC> _di_IEnumFORMATETC;' }
{$ENDIF}
////////////////////////////////////////////////////////////////////////////////
//
// TInterfacedComponent
//
////////////////////////////////////////////////////////////////////////////////
// Top level base class for the drag/drop component hierachy.
// Implements the IUnknown interface.
// Corresponds to TInterfacedObject (see VCL on-line help), but descends from
// TComponent instead of TObject.
// Reference counting is disabled (_AddRef and _Release methods does nothing)
// since the component life span is controlled by the component owner.
////////////////////////////////////////////////////////////////////////////////
type
TInterfacedComponent = class(TComponent, IUnknown)
protected
function QueryInterface(const IID: TGuid; out Obj): HRESULT;
{$IFDEF VER13_PLUS} override; {$ELSE}
{$IFDEF VER12_PLUS} reintroduce; {$ENDIF}{$ENDIF} stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
// Abstract base class. Extracts or injects data of a specific low level format
// from or to an IDataObject.
////////////////////////////////////////////////////////////////////////////////
type
TCustomDataFormat = class;
TClipboardFormat = class(TObject)
private
FDataDirections: TDataDirections;
FDataFormat: TCustomDataFormat;
protected
FFormatEtc: TFormatEtc;
constructor CreateFormat(Atymed: Longint); virtual;
constructor CreateFormatEtc(const AFormatEtc: TFormatEtc); virtual;
{ Extracts data from the specified medium }
function DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean; virtual;
{ Transfer data to the specified medium }
function DoSetData(const FormatEtcIn: TFormatEtc;
var AMedium: TStgMedium): boolean; virtual;
function GetClipboardFormat: TClipFormat; virtual;
procedure SetClipboardFormat(Value: TClipFormat); virtual;
function GetClipboardFormatName: string; virtual;
procedure SetClipboardFormatName(const Value: string); virtual;
procedure SetFormatEtc(const Value: TFormatEtc);
public
constructor Create; virtual; abstract;
destructor Destroy; override;
{ Determines if the object can read from the specified data object }
function HasValidFormats(ADataObject: IDataObject): boolean; virtual;
{ Determines if the object can read the specified format }
function AcceptFormat(const AFormatEtc: TFormatEtc): boolean; virtual;
{ Extracts data from the specified IDataObject }
function GetData(ADataObject: IDataObject): boolean; virtual;
{ Extracts data from the specified IDataObject via the specified medium }
function GetDataFromMedium(ADataObject: IDataObject;
var AMedium: TStgMedium): boolean; virtual;
{ Transfers data to the specified IDataObject }
function SetData(ADataObject: IDataObject; const FormatEtcIn: TFormatEtc;
var AMedium: TStgMedium): boolean; virtual;
{ Transfers data to the specified medium }
function SetDataToMedium(const FormatEtcIn: TFormatEtc;
var AMedium: TStgMedium): boolean;
{ Copies data from the specified source format to the object }
function Assign(Source: TCustomDataFormat): boolean; virtual;
{ Copies data from the object to the specified target format }
function AssignTo(Dest: TCustomDataFormat): boolean; virtual;
{ Clears the objects data }
procedure Clear; virtual; abstract;
{ Returns true if object can supply data }
function HasData: boolean; virtual;
{ Unregisters the clipboard format and all mappings involving it from the global database }
class procedure UnregisterClipboardFormat;
{ Returns the clipboard format value }
property ClipboardFormat: TClipFormat read GetClipboardFormat
write SetClipboardFormat;
{ Returns the clipboard format name }
property ClipboardFormatName: string read GetClipboardFormatName
write SetClipboardFormatName;
{ Provides access to the objects format specification }
property FormatEtc: TFormatEtc read FFormatEtc;
{ Specifies whether the format can read and write data }
property DataDirections: TDataDirections read FDataDirections
write FDataDirections;
{ Specifies the data format which owns and controls this clipboard format }
property DataFormat: TCustomDataFormat read FDataFormat write FDataFormat;
end;
TClipboardFormatClass = class of TClipboardFormat;
// TClipboardFormats
// List of TClipboardFormat objects.
TClipboardFormats = class(TObject)
private
FList: TList;
FOwnsObjects: boolean;
FDataFormat: TCustomDataFormat;
protected
function GetFormat(Index: integer): TClipboardFormat;
function GetCount: integer;
public
constructor Create(ADataFormat: TCustomDataFormat; AOwnsObjects: boolean);
destructor Destroy; override;
procedure Clear;
function Add(ClipboardFormat: TClipboardFormat): integer;
function Contain(ClipboardFormatClass: TClipboardFormatClass): boolean;
function FindFormat(ClipboardFormatClass: TClipboardFormatClass): TClipboardFormat;
property Formats[Index: integer]: TClipboardFormat read GetFormat; default;
property Count: integer read GetCount;
property DataFormat: TCustomDataFormat read FDataFormat;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TDragDropComponent
//
////////////////////////////////////////////////////////////////////////////////
// Base class for drag/drop components.
////////////////////////////////////////////////////////////////////////////////
TDataFormats = class;
TDragDropComponent = class(TInterfacedComponent)
private
protected
FDataFormats: TDataFormats;
//: Only used by TCustomDropMultiSource and TCustomDropMultiTarget and
// their descendants.
property DataFormats: TDataFormats read FDataFormats;
public
end;
////////////////////////////////////////////////////////////////////////////////
//
// TCustomFormat
//
////////////////////////////////////////////////////////////////////////////////
// Abstract base class.
// Renders the data of one or more TClipboardFormat objects to or from a
// specific high level data format.
////////////////////////////////////////////////////////////////////////////////
TCustomDataFormat = class(TObject)
private
FCompatibleFormats : TClipboardFormats;
FFormatList : TDataFormats;
FOwner : TDragDropComponent;
FOnChanging : TNotifyEvent;
protected
{ Determines if the object can accept data from the specified source format }
function SupportsFormat(ClipboardFormat: TClipboardFormat): boolean;
procedure DoOnChanging(Sender: TObject);
procedure Changing; virtual;
property FormatList: TDataFormats read FFormatList;
public
constructor Create(AOwner: TDragDropComponent); virtual;
destructor Destroy; override;
procedure Clear; virtual; abstract;
{ Copies data between the specified clipboard format to the object }
function Assign(Source: TClipboardFormat): boolean; virtual;
function AssignTo(Dest: TClipboardFormat): boolean; virtual;
{ Extracts data from the specified IDataObject }
function GetData(DataObject: IDataObject): boolean; virtual;
{ Determines if the object contains *any* data }
function HasData: boolean; virtual; abstract;
{ Determines if the object needs/can use *more* data }
function NeedsData: boolean; virtual;
{ Determines if the object can read from the specified data object }
function HasValidFormats(ADataObject: IDataObject): boolean; virtual;
{ Determines if the object can read the specified format }
function AcceptFormat(const FormatEtc: TFormatEtc): boolean; virtual;
{ Registers the data format in the data format list }
class procedure RegisterDataFormat;
{ Registers the specified clipboard format as being compatible with the data format }
class procedure RegisterCompatibleFormat(ClipboardFormatClass: TClipboardFormatClass;
Priority: integer {$ifdef VER12_PLUS} = 0 {$endif};
ConversionScopes: TConversionScopes {$ifdef VER12_PLUS} = csSourceTarget {$endif};
DataDirections: TDataDirections {$ifdef VER12_PLUS} = [ddRead] {$endif});
{ Unregisters the specified clipboard format from the compatibility list }
class procedure UnregisterCompatibleFormat(ClipboardFormatClass: TClipboardFormatClass);
{ Unregisters data format and all mappings involving it from the global database }
class procedure UnregisterDataFormat;
{ List of compatible source formats }
property CompatibleFormats: TClipboardFormats read FCompatibleFormats;
property Owner: TDragDropComponent read FOwner;
property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
// TODO : Add support for delayed rendering with DelayedRender property.
end;
// TDataFormats
// List of TCustomDataFormat objects.
TDataFormats = class(TObject)
private
FList: TList;
protected
function GetFormat(Index: integer): TCustomDataFormat;
function GetCount: integer;
public
constructor Create;
destructor Destroy; override;
function Add(DataFormat: TCustomDataFormat): integer; virtual;
function IndexOf(DataFormat: TCustomDataFormat): integer; virtual;
procedure Remove(DataFormat: TCustomDataFormat); virtual;
property Formats[Index: integer]: TCustomDataFormat read GetFormat; default;
property Count: integer read GetCount;
end;
// TDataFormatClasses
// List of TCustomDataFormat classes.
TDataFormatClass = class of TCustomDataFormat;
TDataFormatClasses = class(TObject)
private
FList: TList;
protected
function GetFormat(Index: integer): TDataFormatClass;
function GetCount: integer;
{ Provides singleton access to the global data format database }
class function Instance: TDataFormatClasses;
public
constructor Create;
destructor Destroy; override;
function Add(DataFormat: TDataFormatClass): integer; virtual;
procedure Remove(DataFormat: TDataFormatClass); virtual;
property Formats[Index: integer]: TDataFormatClass read GetFormat; default;
property Count: integer read GetCount;
end;
// TDataFormatMap
// Format conversion database. Contains mappings between TClipboardFormat
// and TCustomDataFormat.
// Used internally by TCustomDropMultiTarget and TCustomDropMultiSource.
TDataFormatMap = class(TObject)
FList: TList;
protected
function FindMap(DataFormatClass: TDataFormatClass; ClipboardFormatClass: TClipboardFormatClass): integer;
procedure Sort;
{ Provides singleton access to the global format map database }
class function Instance: TDataFormatMap;
public
constructor Create;
destructor Destroy; override;
procedure Add(DataFormatClass: TDataFormatClass;
ClipboardFormatClass: TClipboardFormatClass;
Priority: integer {$ifdef VER12_PLUS} = 0 {$endif};
ConversionScopes: TConversionScopes {$ifdef VER12_PLUS} = csSourceTarget {$endif};
DataDirections: TDataDirections {$ifdef VER12_PLUS} = [ddRead] {$endif});
procedure Delete(DataFormatClass: TDataFormatClass;
ClipboardFormatClass: TClipboardFormatClass);
procedure DeleteByClipboardFormat(ClipboardFormatClass: TClipboardFormatClass);
procedure DeleteByDataFormat(DataFormatClass: TDataFormatClass);
procedure GetSourceByDataFormat(DataFormatClass: TDataFormatClass;
ClipboardFormats: TClipboardFormats; ConversionScope: TConversionScope);
function CanMap(DataFormatClass: TDataFormatClass;
ClipboardFormatClass: TClipboardFormatClass): boolean;
{ Registers the specified format mapping }
procedure RegisterFormatMap(DataFormatClass: TDataFormatClass;
ClipboardFormatClass: TClipboardFormatClass;
Priority: integer {$ifdef VER12_PLUS} = 0 {$endif};
ConversionScopes: TConversionScopes {$ifdef VER12_PLUS} = csSourceTarget {$endif};
DataDirections: TDataDirections {$ifdef VER12_PLUS} = [ddRead] {$endif});
{ Unregisters the specified format mapping }
procedure UnregisterFormatMap(DataFormatClass: TDataFormatClass;
ClipboardFormatClass: TClipboardFormatClass);
end;
////////////////////////////////////////////////////////////////////////////////
//
// TDataFormatAdapter
//
////////////////////////////////////////////////////////////////////////////////
// Helper component used to add additional data formats to a drop source or
// target at design time.
// Requires that data formats have been registered with
// TCustomDataFormat.RegisterDataFormat.
////////////////////////////////////////////////////////////////////////////////
TDataFormatAdapter = class(TComponent)
private
FDragDropComponent: TDragDropComponent;
FDataFormat: TCustomDataFormat;
FDataFormatClass: TDataFormatClass;
FEnabled: boolean;
function GetDataFormatName: string;
procedure SetDataFormatName(const Value: string);
protected
procedure SetDataFormatClass(const Value: TDataFormatClass);
procedure SetDragDropComponent(const Value: TDragDropComponent);
function GetEnabled: boolean;
procedure SetEnabled(const Value: boolean);
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
procedure Loaded; override;
public
destructor Destroy; override;
property DataFormatClass: TDataFormatClass read FDataFormatClass
write SetDataFormatClass;
property DataFormat: TCustomDataFormat read FDataFormat;
published
property DragDropComponent: TDragDropComponent read FDragDropComponent
write SetDragDropComponent;
property DataFormatName: string read GetDataFormatName
write SetDataFormatName;
property Enabled: boolean read GetEnabled write SetEnabled;
end;
////////////////////////////////////////////////////////////////////////////////
//
// Drag Drop helper interfaces
//
////////////////////////////////////////////////////////////////////////////////
// Requires Windows 2000 or later.
////////////////////////////////////////////////////////////////////////////////
type
PSHDRAGIMAGE = ^TSHDRAGIMAGE;
{_$EXTERNALSYM _SHDRAGIMAGE}
_SHDRAGIMAGE = packed record
sizeDragImage: TSize; { The length and Width of the rendered image }
ptOffset: TPoint; { The Offset from the mouse cursor to the upper left corner of the image }
hbmpDragImage: HBitmap; { The Bitmap containing the rendered drag images }
crColorKey: COLORREF; { The COLORREF that has been blitted to the background of the images }
end;
TSHDRAGIMAGE = _SHDRAGIMAGE;
{_$EXTERNALSYM SHDRAGIMAGE}
SHDRAGIMAGE = _SHDRAGIMAGE;
const
CLSID_DragDropHelper: TGUID = (
D1:$4657278a; D2:$411b; D3:$11d2; D4:($83,$9a,$00,$c0,$4f,$d9,$18,$d0));
SID_DragDropHelper = '{4657278A-411B-11d2-839A-00C04FD918D0}';
const
IID_IDropTargetHelper: TGUID = (
D1:$4657278b; D2:$411b; D3:$11d2; D4:($83,$9a,$00,$c0,$4f,$d9,$18,$d0));
SID_IDropTargetHelper = '{4657278B-411B-11d2-839A-00C04FD918D0}';
type
{_$HPPEMIT 'typedef DragDrop::DelphiInterface<IDropTargetHelper> _di_IDropTargetHelper;'}
{_$EXTERNALSYM IDropTargetHelper}
IDropTargetHelper = interface(IUnknown)
[SID_IDropTargetHelper]
function DragEnter(hwndTarget: HWND; const DataObj: IDataObject;
var pt: TPoint; dwEffect: Longint): HResult; stdcall;
function DragLeave: HResult; stdcall;
function DragOver(var pt: TPoint; dwEffect: longInt): HResult; stdcall;
function Drop(const DataObj: IDataObject; var pt: TPoint;
dwEffect: longInt): HResult; stdcall;
function Show(Show: BOOL): HResult; stdcall;
end;
const
IID_IDragSourceHelper: TGUID = (
D1:$de5bf786; D2:$477a; D3:$11d2; D4:($83,$9d,$00,$c0,$4f,$d9,$18,$d0));
SID_IDragSourceHelper = '{DE5BF786-477A-11d2-839D-00C04FD918D0}';
type
{_$HPPEMIT 'typedef DragDrop::DelphiInterface<IDragSourceHelper> _di_IDragSourceHelper;'}
{_$EXTERNALSYM IDragSourceHelper}
IDragSourceHelper = interface(IUnknown)
[SID_IDragSourceHelper]
function InitializeFromBitmap(var shdi: TSHDRAGIMAGE;
const DataObj: IDataObject): HResult; stdcall;
function InitializeFromWindow(hwnd: HWND; var pt: TPoint;
const DataObj: IDataObject): HResult; stdcall;
end;
////////////////////////////////////////////////////////////////////////////////
//
// Async data transfer interfaces
//
////////////////////////////////////////////////////////////////////////////////
// Requires Windows 2000 or later.
////////////////////////////////////////////////////////////////////////////////
const
IID_IAsyncOperation: TGUID = (
D1:$3D8B0590; D2:$F691; D3:$11D2; D4:($8E,$A9,$00,$60,$97,$DF,$5B,$D4));
SID_IAsyncOperation = '{3D8B0590-F691-11D2-8EA9-006097DF5BD4}';
type
{_$HPPEMIT 'typedef DragDrop::DelphiInterface<IAsyncOperation> _di_IAsyncOperation;'}
{_$EXTERNALSYM IAsyncOperation}
IAsyncOperation = interface(IUnknown)
[SID_IAsyncOperation]
function SetAsyncMode(fDoOpAsync: BOOL): HResult; stdcall;
function GetAsyncMode(out fDoOpAsync: BOOL): HResult; stdcall;
function StartOperation(const pbcReserved: IBindCtx): HResult; stdcall;
function InOperation(out pfInAsyncOp: BOOL): HResult; stdcall;
function EndOperation(hResult: HRESULT; const pbcReserved: IBindCtx;
dwEffects: DWORD): HResult; stdcall;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TRawClipboardFormat & TRawDataFormat
//
////////////////////////////////////////////////////////////////////////////////
// These clipboard and data format classes are special in that they don't
// interpret the data in any way.
// Their primary purpose is to enable the TCustomDropMultiSource class to accept
// and store arbitrary (and unknown) data types. This is a requirement for
// drag drop helper object support.
////////////////////////////////////////////////////////////////////////////////
// The TRawDataFormat class does not perform any storage of data itself. Instead
// it relies on the TRawClipboardFormat objects to store data.
////////////////////////////////////////////////////////////////////////////////
TRawDataFormat = class(TCustomDataFormat)
private
FMedium: TStgMedium;
protected
public
procedure Clear; override;
function HasData: boolean; override;
function NeedsData: boolean; override;
property Medium: TStgMedium read FMedium write FMedium;
end;
TRawClipboardFormat = class(TClipboardFormat)
private
FMedium: TStgMedium;
protected
function DoGetData(ADataObject: IDataObject;
const AMedium: TStgMedium): boolean; override;
function DoSetData(const FormatEtcIn: TFormatEtc;
var AMedium: TStgMedium): boolean; override;
procedure SetClipboardFormatName(const Value: string); override;
function GetClipboardFormat: TClipFormat; override;
function GetString: string;
procedure SetString(const Value: string);
public
constructor Create; override;
constructor CreateFormatEtc(const AFormatEtc: TFormatEtc); override;
function Assign(Source: TCustomDataFormat): boolean; override;
function AssignTo(Dest: TCustomDataFormat): boolean; override;
procedure Clear; override;
// Methods to handle the corresponding TRawDataFormat functioinality.
procedure ClearData;
function HasData: boolean; override;
function NeedsData: boolean;
// All of these should be moved/mirrored in TRawDataFormat:
procedure CopyFromStgMedium(const AMedium: TStgMedium);
procedure CopyToStgMedium(var AMedium: TStgMedium);
property AsString: string read GetString write SetString;
property Medium: TStgMedium read FMedium write FMedium;
end;
////////////////////////////////////////////////////////////////////////////////
//
// Utility functions
//
////////////////////////////////////////////////////////////////////////////////
function DropEffectToDragType(DropEffect: longInt; var DragType: TDragType): boolean;
function DragTypesToDropEffect(DragTypes: TDragTypes): longint; // V4: New
// Coordinate space conversion.
function ClientPtToWindowPt(Handle: THandle; pt: TPoint): TPoint;
// Replacement for KeysToShiftState.
function KeysToShiftStatePlus(Keys: Word): TShiftState; // V4: New
function ShiftStateToDropEffect(Shift: TShiftState; AllowedEffects: longint;
Fallback: boolean): longint;
// Replacement for the buggy DragDetect API function.
function DragDetectPlus(Handle: THandle; p: TPoint): boolean; // V4: New
// Wrapper for urlmon.CopyStgMedium.
// Note: Only works with IE4 or later installed.
function CopyStgMedium(const SrcMedium: TStgMedium; var DstMedium: TStgMedium): boolean;
// Get the name of a clipboard format as a Delphi string.
function GetClipboardFormatNameStr(Value: TClipFormat): string;
// Raise last Windows API error as an exception.
procedure _RaiseLastWin32Error;
////////////////////////////////////////////////////////////////////////////////
//
// Global variables
//
////////////////////////////////////////////////////////////////////////////////
var
ShellMalloc: IMalloc;
// Name of the IDE component palette page the drag drop components are
// registered to
var
DragDropComponentPalettePage: string = 'DragDrop';
////////////////////////////////////////////////////////////////////////////////
//
// Misc drop target related constants
//
////////////////////////////////////////////////////////////////////////////////
// Drag Drop constants from ActiveX unit
var
// Default inset-width of the auto scroll hot zone.
// Specified in pixels.
// Not used! Instead the height of the target control's font is used.
DragDropScrollInset: integer = DD_DEFSCROLLINSET; // 11
// Default delay after entering the scroll zone, before scrolling starts.
// Specified in milliseconds.
DragDropScrollDelay: integer = DD_DEFSCROLLDELAY; // 50
// Default scroll interval during auto scroll.
// Specified in milliseconds.
DragDropScrollInterval: integer = DD_DEFSCROLLINTERVAL; // 50
// Default delay before dragging should start.
// Specified in milliseconds.
DragDropDragDelay: integer = DD_DEFDRAGDELAY; // 200
// Default minimum distance (radius) before dragging should start.
// Specified in pixels.
// Not used! Instead the SM_CXDRAG and SM_CYDRAG system metrics are used.
DragDropDragMinDistance: integer = DD_DEFDRAGMINDIST; // 2
////////////////////////////////////////////////////////////////////////////////
//
// Misc drag drop API related constants
//
////////////////////////////////////////////////////////////////////////////////
// The following DVASPECT constants are missing from some versions of Delphi and
// C++ Builder.
{$ifndef VER135_PLUS}
const
{$ifndef VER10_PLUS}
DVASPECT_SHORTNAME = 2; // use for CF_HDROP to get short name version of file paths
{$endif}
DVASPECT_COPY = 3; // use to indicate format is a "Copy" of the data (FILECONTENTS, FILEDESCRIPTOR, etc)
DVASPECT_LINK = 4; // use to indicate format is a "Shortcut" to the data (FILECONTENTS, FILEDESCRIPTOR, etc)
{$endif}
////////////////////////////////////////////////////////////////////////////////
//
// Component registration
//
////////////////////////////////////////////////////////////////////////////////
procedure Register;
(*******************************************************************************
**
** IMPLEMENTATION
**
*******************************************************************************)
implementation
uses
{$ifdef DEBUG}
ComObj,
{$endif}
DropSource,
DropTarget,
DragDropFormats, // Used by TRawClipboardFormat
Messages,
ShlObj,
MMSystem,
SysUtils;
resourcestring
sImplementationRequired = 'Internal error: %s.%s needs implementation';
sInvalidOwnerType = '%s is not a valid owner for %s. Owner must be derived from %s';
sFormatNameReadOnly = '%s.ClipboardFormat is read-only';
sNoCopyStgMedium = 'A required system function (URLMON.CopyStgMedium) was not available on this system. Operation aborted.';
sBadConstructor = 'The %s class can not be instantiated with the default constructor';
sUnregisteredDataFormat = 'The %s data format has not been registered by any of the used units';
////////////////////////////////////////////////////////////////////////////////
//
// Component registration
//
////////////////////////////////////////////////////////////////////////////////
procedure Register;
begin
RegisterComponents(DragDropComponentPalettePage, [TDataFormatAdapter]);
end;
////////////////////////////////////////////////////////////////////////////////
//
// TInterfacedComponent
//
////////////////////////////////////////////////////////////////////////////////
function TInterfacedComponent.QueryInterface(const IID: TGuid; out Obj): HRESULT;
{$ifdef DEBUG}
function GuidToString(const IID: TGuid): string;
var
GUID: string;
begin
GUID := ComObj.GUIDToString(IID);
Result := GetRegStringValue('Interface\'+GUID, '');
if (Result = '') then
Result := GUID;
end;
{$endif}
begin
{$ifdef VER12_PLUS}
if GetInterface(IID, Obj) then
Result := 0
else if (VCLComObject <> nil) then
Result := IVCLComObject(VCLComObject).QueryInterface(IID, Obj)
else
Result := E_NOINTERFACE;
{$else}
Result := inherited QueryInterface(IID, Obj);
{$endif}
{$ifdef DEBUG}
OutputDebugString(PChar(format('%s.QueryInterface(%s): %d (%d)',
[ClassName, GuidToString(IID), Result, ord(pointer(Obj) <> nil)])));
{$endif}
end;
function TInterfacedComponent._AddRef: Integer;
var
Outer: IUnknown;
begin
// In case we are the inner object of an aggregation, we attempt to delegate
// the reference counting to the outer object. We assume that the component
// owner is the outer object.
if (Owner <> nil) and (Owner.GetInterface(IUnknown, Outer)) then
Result := Outer._AddRef
else
begin
{$ifdef VER12_PLUS}
inherited _AddRef;
{$else}
if (VCLComObject <> nil) then
inherited _AddRef;
{$endif}
Result := -1;
end;
end;
function TInterfacedComponent._Release: Integer;
var
Outer: IUnknown;
begin
// See _AddRef for comments.
if (Owner <> nil) and (Owner.GetInterface(IUnknown, Outer)) then
Result := Outer._Release
else
begin
{$ifdef VER12_PLUS}
inherited _Release;
{$else}
if (VCLComObject <> nil) then
inherited _Release;
{$endif}
Result := -1;
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
destructor TClipboardFormat.Destroy;
begin
// Warning: Do not call Clear here. Descendant class has already
// cleaned up and released resources!
inherited Destroy;
end;
constructor TClipboardFormat.CreateFormat(Atymed: Longint);
begin
inherited Create;
FDataDirections := [ddRead];
FFormatEtc.cfFormat := ClipboardFormat;
FFormatEtc.ptd := nil;
FFormatEtc.dwAspect := DVASPECT_CONTENT;
FFormatEtc.lindex := -1;
FFormatEtc.tymed := Atymed;
end;
constructor TClipboardFormat.CreateFormatEtc(const AFormatEtc: TFormatEtc);
begin
inherited Create;
FDataDirections := [ddRead];
FFormatEtc := AFormatEtc;
end;
function TClipboardFormat.HasValidFormats(ADataObject: IDataObject): boolean;
begin
Result := (ADataObject.QueryGetData(FormatEtc) = S_OK);
end;
function TClipboardFormat.AcceptFormat(const AFormatEtc: TFormatEtc): boolean;
begin
Result := (AFormatEtc.cfFormat = FFormatEtc.cfFormat) and
(AFormatEtc.ptd = nil) and
(AFormatEtc.dwAspect = FFormatEtc.dwAspect) and
(AFormatEtc.tymed AND FFormatEtc.tymed <> 0);
end;
function TClipboardFormat.Assign(Source: TCustomDataFormat): boolean;
begin
Result := False;
end;
function TClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean;
begin
Result := False;
end;
function TClipboardFormat.DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean;
begin
Result := False;
end;
function TClipboardFormat.DoSetData(const FormatEtcIn: TFormatEtc;
var AMedium: TStgMedium): boolean;
begin
Result := False;
end;
function TClipboardFormat.GetData(ADataObject: IDataObject): boolean;
var
Medium : TStgMedium;
begin
Result := False;
Clear;
if (ADataObject.GetData(FFormatEtc, Medium) <> S_OK) then
exit;
Result := GetDataFromMedium(ADataObject, Medium);
end;
function TClipboardFormat.GetDataFromMedium(ADataObject: IDataObject;
var AMedium: TStgMedium): boolean;
begin
Result := False;
try
Clear;
if ((AMedium.tymed AND FFormatEtc.tymed) <> 0) then
Result := DoGetData(ADataObject, AMedium);
finally
ReleaseStgMedium(AMedium);
end;
end;
function TClipboardFormat.SetDataToMedium(const FormatEtcIn: TFormatEtc;
var AMedium: TStgMedium): boolean;
begin
Result := False;
FillChar(AMedium, SizeOf(AMedium), 0);
if (FormatEtcIn.cfFormat <> FFormatEtc.cfFormat) or
(FormatEtcIn.dwAspect <> FFormatEtc.dwAspect) or
(FormatEtcIn.tymed and FFormatEtc.tymed = 0) then
exit;
// Call descendant to allocate medium and transfer data to it
Result := DoSetData(FormatEtcIn, AMedium);
end;
function TClipboardFormat.SetData(ADataObject: IDataObject;
const FormatEtcIn: TFormatEtc; var AMedium: TStgMedium): boolean;
begin
// Transfer data to medium
Result := SetDataToMedium(FormatEtcIn, AMedium);
// Call IDataObject to set data
if (Result) then
Result := (ADataObject.SetData(FormatEtc, AMedium, True) = S_OK);
// If we didn't succeed in transfering ownership of the data medium to the
// IDataObject, we must deallocate the medium ourselves.
if (not Result) then
ReleaseStgMedium(AMedium);
end;
class procedure TClipboardFormat.UnregisterClipboardFormat;
begin
TDataFormatMap.Instance.DeleteByClipboardFormat(Self);
end;
function TClipboardFormat.GetClipboardFormat: TClipFormat;
begin
// This should have been a virtual abstract class method, but this isn't supported by C++ Builder.
raise Exception.CreateFmt(sImplementationRequired, [ClassName, 'GetClipboardFormat']);
end;
procedure TClipboardFormat.SetClipboardFormat(Value: TClipFormat);
begin
FFormatEtc.cfFormat := Value;
end;
function TClipboardFormat.GetClipboardFormatName: string;
var
Len : integer;
begin
SetLength(Result, 255); // 255 is just an artificial limit.
Len := Windows.GetClipboardFormatName(GetClipboardFormat, PChar(Result), 255);
SetLength(Result, Len);
end;
procedure TClipboardFormat.SetClipboardFormatName(const Value: string);
begin
raise Exception.CreateFmt(sFormatNameReadOnly, [ClassName]);
end;
function TClipboardFormat.HasData: boolean;
begin
// Descendant classes are not required to override this method, so by default
// we just pretend that data is available. No harm is done by this.
Result := True;
end;
procedure TClipboardFormat.SetFormatEtc(const Value: TFormatEtc);
begin
FFormatEtc := Value;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TClipboardFormats
//
////////////////////////////////////////////////////////////////////////////////
constructor TClipboardFormats.Create(ADataFormat: TCustomDataFormat;
AOwnsObjects: boolean);
begin
inherited Create;
FList := TList.Create;
FDataFormat := ADataFormat;
FOwnsObjects := AOwnsObjects;
end;
destructor TClipboardFormats.Destroy;
begin
Clear;
FList.Free;
inherited Destroy;
end;
function TClipboardFormats.Add(ClipboardFormat: TClipboardFormat): integer;
begin
Result := FList.Add(ClipboardFormat);
if (FOwnsObjects) and (DataFormat <> nil) then
ClipboardFormat.DataFormat := DataFormat;
end;
function TClipboardFormats.FindFormat(ClipboardFormatClass: TClipboardFormatClass): TClipboardFormat;
var
i : integer;
begin
// Search list for an object of the specified type
for i := 0 to Count-1 do
if (Formats[i].InheritsFrom(ClipboardFormatClass)) then
begin
Result := Formats[i];
exit;
end;
Result := nil;
end;
function TClipboardFormats.Contain(ClipboardFormatClass: TClipboardFormatClass): boolean;
begin
Result := (FindFormat(ClipboardFormatClass) <> nil);
end;
function TClipboardFormats.GetCount: integer;
begin
Result := FList.Count;
end;
function TClipboardFormats.GetFormat(Index: integer): TClipboardFormat;
begin
Result := TClipboardFormat(FList[Index]);
end;
procedure TClipboardFormats.Clear;
var
i : integer;
Format : TObject;
begin
if (FOwnsObjects) then
// Empty list and delete all objects in it
for i := Count-1 downto 0 do
begin
Format := Formats[i];
FList.Delete(i);
Format.Free;
end;
FList.Clear;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TCustomDataFormat
//
////////////////////////////////////////////////////////////////////////////////
constructor TCustomDataFormat.Create(AOwner: TDragDropComponent);
var
ConversionScope: TConversionScope;
begin
if (AOwner <> nil) then
begin
if (AOwner is TCustomDropMultiSource) then
ConversionScope := csSource
else if (AOwner is TCustomDropMultiTarget) then
ConversionScope := csTarget
else
raise Exception.CreateFmt(sInvalidOwnerType, [AOwner.ClassName, ClassName,
'TCustomDropMultiSource or TCustomDropMultiTarget']);
// Add object to owners list of data formats.
FOwner := AOwner;
end else
// TODO : This sucks! All this ConversionScope stuff should be redesigned.
ConversionScope := csTarget;
FCompatibleFormats := TClipboardFormats.Create(Self, True);
// Populate list with all the clipboard formats that have been registered as
// compatible with this data format.
TDataFormatMap.Instance.GetSourceByDataFormat(TDataFormatClass(ClassType),
FCompatibleFormats, ConversionScope);
if (FOwner <> nil) then
FOwner.DataFormats.Add(Self);
end;
destructor TCustomDataFormat.Destroy;
begin
FCompatibleFormats.Free;
// Remove object from owners list of target formats
if (FOwner <> nil) then
FOwner.DataFormats.Remove(Self);
inherited Destroy;
end;
function TCustomDataFormat.Assign(Source: TClipboardFormat): boolean;
begin
// Called when derived class(es) couldn't convert from the source format.
// Try to let source format convert to this format instead.
Result := Source.AssignTo(Self);
end;
function TCustomDataFormat.AssignTo(Dest: TClipboardFormat): boolean;
begin
// Called when derived class(es) couldn't convert to the destination format.
// Try to let destination format convert from this format instead.
Result := Dest.Assign(Self);
end;
function TCustomDataFormat.GetData(DataObject: IDataObject): boolean;
var
i: integer;
begin
Result := False;
i := 0;
// Get data from each of our associated clipboard formats until we don't
// need anymore data.
while (NeedsData) and (i < CompatibleFormats.Count) do
begin
CompatibleFormats[i].Clear;
if (CompatibleFormats[i].GetData(DataObject)) and
(CompatibleFormats[i].HasData) then
begin
if (Assign(CompatibleFormats[i])) then
begin
// Once data has been sucessfully transfered to the TDataFormat object,
// we clear the data in the TClipboardFormat object in order to conserve
// resources.
CompatibleFormats[i].Clear;
Result := True;
end;
end;
inc(i);
end;
end;
function TCustomDataFormat.NeedsData: boolean;
begin
Result := not HasData;
end;
function TCustomDataFormat.HasValidFormats(ADataObject: IDataObject): boolean;
var
i: integer;
begin
// Determine if any of the registered clipboard formats can read from the
// specified data object.
Result := False;
for i := 0 to CompatibleFormats.Count-1 do
if (CompatibleFormats[i].HasValidFormats(ADataObject)) then
begin
Result := True;
break;
end;
end;
function TCustomDataFormat.AcceptFormat(const FormatEtc: TFormatEtc): boolean;
var
i: integer;
begin
// Determine if any of the registered clipboard formats can handle the
// specified clipboard format.
Result := False;
for i := 0 to CompatibleFormats.Count-1 do
if (CompatibleFormats[i].AcceptFormat(FormatEtc)) then
begin
Result := True;
break;
end;
end;
class procedure TCustomDataFormat.RegisterDataFormat;
begin
TDataFormatClasses.Instance.Add(Self);
end;
class procedure TCustomDataFormat.RegisterCompatibleFormat(ClipboardFormatClass: TClipboardFormatClass;
Priority: integer; ConversionScopes: TConversionScopes;
DataDirections: TDataDirections);
begin
// Register format mapping.
TDataFormatMap.Instance.RegisterFormatMap(Self, ClipboardFormatClass,
Priority, ConversionScopes, DataDirections);
end;
function TCustomDataFormat.SupportsFormat(ClipboardFormat: TClipboardFormat): boolean;
begin
Result := CompatibleFormats.Contain(TClipboardFormatClass(ClipboardFormat.ClassType));
end;
class procedure TCustomDataFormat.UnregisterCompatibleFormat(ClipboardFormatClass: TClipboardFormatClass);
begin
// Unregister format mapping
TDataFormatMap.Instance.UnregisterFormatMap(Self, ClipboardFormatClass);
end;
class procedure TCustomDataFormat.UnregisterDataFormat;
begin
TDataFormatMap.Instance.DeleteByDataFormat(Self);
TDataFormatClasses.Instance.Remove(Self);
end;
procedure TCustomDataFormat.DoOnChanging(Sender: TObject);
begin
Changing;
end;
procedure TCustomDataFormat.Changing;
begin
if (Assigned(OnChanging)) then
OnChanging(Self);
end;
////////////////////////////////////////////////////////////////////////////////
//
// TDataFormats
//
////////////////////////////////////////////////////////////////////////////////
function TDataFormats.Add(DataFormat: TCustomDataFormat): integer;
begin
Result := FList.IndexOf(DataFormat);
if (Result = -1) then
Result := FList.Add(DataFormat);
end;
constructor TDataFormats.Create;
begin
inherited Create;
FList := TList.Create;
end;
destructor TDataFormats.Destroy;
var
i: integer;
begin
for i := FList.Count-1 downto 0 do
Remove(TCustomDataFormat(FList[i]));
FList.Free;
inherited Destroy;
end;
function TDataFormats.GetCount: integer;
begin
Result := FList.Count;
end;
function TDataFormats.GetFormat(Index: integer): TCustomDataFormat;
begin
Result := TCustomDataFormat(FList[Index]);
end;
function TDataFormats.IndexOf(DataFormat: TCustomDataFormat): integer;
begin
Result := FList.IndexOf(DataFormat);
end;
procedure TDataFormats.Remove(DataFormat: TCustomDataFormat);
begin
FList.Remove(DataFormat);
end;
////////////////////////////////////////////////////////////////////////////////
//
// TDataFormatClasses
//
////////////////////////////////////////////////////////////////////////////////
function TDataFormatClasses.Add(DataFormat: TDataFormatClass): integer;
begin
Result := FList.IndexOf(DataFormat);
if (Result = -1) then
Result := FList.Add(DataFormat);
end;
constructor TDataFormatClasses.Create;
begin
inherited Create;
FList := TList.Create;
end;
destructor TDataFormatClasses.Destroy;
var
i: integer;
begin
for i := FList.Count-1 downto 0 do
Remove(TDataFormatClass(FList[i]));
FList.Free;
inherited Destroy;
end;
function TDataFormatClasses.GetCount: integer;
begin
Result := FList.Count;
end;
function TDataFormatClasses.GetFormat(Index: integer): TDataFormatClass;
begin
Result := TDataFormatClass(FList[Index]);
end;
var
FDataFormatClasses: TDataFormatClasses = nil;
class function TDataFormatClasses.Instance: TDataFormatClasses;
begin
if (FDataFormatClasses = nil) then
FDataFormatClasses := TDataFormatClasses.Create;
Result := FDataFormatClasses;
end;
procedure TDataFormatClasses.Remove(DataFormat: TDataFormatClass);
begin
FList.Remove(DataFormat);
end;
////////////////////////////////////////////////////////////////////////////////
//
// TDataFormatMap
//
////////////////////////////////////////////////////////////////////////////////
type
// TTargetFormat / TClipboardFormat association
TFormatMap = record
DataFormat: TDataFormatClass;
ClipboardFormat: TClipboardFormatClass;
Priority: integer;
ConversionScopes: TConversionScopes;
DataDirections: TDataDirections;
end;
PFormatMap = ^TFormatMap;
constructor TDataFormatMap.Create;
begin
inherited Create;
FList := TList.Create;
end;
destructor TDataFormatMap.Destroy;
var
i : integer;
begin
// Zap any mapings which hasn't been unregistered
// yet (actually an error condition)
for i := FList.Count-1 downto 0 do
Dispose(FList[i]);
FList.Free;
inherited Destroy;
end;
procedure TDataFormatMap.Sort;
var
i : integer;
NewMap : PFormatMap;
begin
// Note: We do not use the built-in Sort method of TList because
// we need to preserve the order in which the mappings were added.
// New mappings have higher precedence than old mappings (within the
// same priority).
// Preconditions:
// 1) The list is already sorted before a new mapping is added.
// 2) The new mapping is always added to the end of the list.
NewMap := PFormatMap(FList.Last);
// Scan the list for a map with the same TTargetFormat type
i := FList.Count-2;
while (i > 0) do
begin
if (PFormatMap(FList[i])^.DataFormat = NewMap^.DataFormat) then
begin
// Scan the list for a map with lower priority
repeat
if (PFormatMap(FList[i])^.Priority < NewMap^.Priority) then
begin
// Move the mapping to the new position
FList.Move(FList.Count-1, i+1);
exit;
end;
dec(i);
until (i < 0) or (PFormatMap(FList[i])^.DataFormat <> NewMap^.DataFormat);
// Move the mapping to the new position
FList.Move(FList.Count-1, i+1);
exit;
end;
dec(i);
end;
end;
procedure TDataFormatMap.Add(DataFormatClass: TDataFormatClass;
ClipboardFormatClass: TClipboardFormatClass; Priority: integer;
ConversionScopes: TConversionScopes; DataDirections: TDataDirections);
var
FormatMap : PFormatMap;
OldMap : integer;
begin
// Avoid duplicate mappings
OldMap := FindMap(DataFormatClass, ClipboardFormatClass);
if (OldMap = -1) then
begin
// Add new mapping...
New(FormatMap);
FList.Add(FormatMap);
FormatMap^.ConversionScopes := ConversionScopes;
FormatMap^.DataDirections := DataDirections;
end else
begin
// Replace old mapping...
FormatMap := FList[OldMap];
FList.Move(OldMap, FList.Count-1);
FormatMap^.ConversionScopes := FormatMap^.ConversionScopes + ConversionScopes;
FormatMap^.DataDirections := FormatMap^.DataDirections + DataDirections;
end;
FormatMap^.ClipboardFormat := ClipboardFormatClass;
FormatMap^.DataFormat := DataFormatClass;
FormatMap^.Priority := Priority;
// ...and sort list
Sort;
end;
function TDataFormatMap.CanMap(DataFormatClass: TDataFormatClass;
ClipboardFormatClass: TClipboardFormatClass): boolean;
begin
Result := (FindMap(DataFormatClass, ClipboardFormatClass) <> -1);
end;
procedure TDataFormatMap.Delete(DataFormatClass: TDataFormatClass;
ClipboardFormatClass: TClipboardFormatClass);
var
Index : integer;
begin
Index := FindMap(DataFormatClass, ClipboardFormatClass);
if (Index <> -1) then
begin
Dispose(FList[Index]);
FList.Delete(Index);
end;
end;
procedure TDataFormatMap.DeleteByClipboardFormat(ClipboardFormatClass: TClipboardFormatClass);
var
i : integer;
begin
// Delete all mappings associated with the specified clipboard format
for i := FList.Count-1 downto 0 do
if (PFormatMap(FList[i])^.ClipboardFormat.InheritsFrom(ClipboardFormatClass)) then
begin
Dispose(FList[i]);
FList.Delete(i);
end;
end;
procedure TDataFormatMap.DeleteByDataFormat(DataFormatClass: TDataFormatClass);
var
i : integer;
begin
// Delete all mappings associated with the specified target format
for i := FList.Count-1 downto 0 do
if (PFormatMap(FList[i])^.DataFormat.InheritsFrom(DataFormatClass)) then
begin
Dispose(FList[i]);
FList.Delete(i);
end;
end;
function TDataFormatMap.FindMap(DataFormatClass: TDataFormatClass;
ClipboardFormatClass: TClipboardFormatClass): integer;
var
i : integer;
begin
for i := 0 to FList.Count-1 do
if (PFormatMap(FList[i])^.DataFormat.InheritsFrom(DataFormatClass)) and
(PFormatMap(FList[i])^.ClipboardFormat.InheritsFrom(ClipboardFormatClass)) then
begin
Result := i;
exit;
end;
Result := -1;
end;
procedure TDataFormatMap.GetSourceByDataFormat(DataFormatClass: TDataFormatClass;
ClipboardFormats: TClipboardFormats; ConversionScope: TConversionScope);
var
i: integer;
ClipboardFormat: TClipboardFormat;
begin
// Clear the list...
ClipboardFormats.Clear;
// ...and populate it with *instances* of all the clipbard
// formats associated with the specified target format and
// registered with the specified data direction.
for i := 0 to FList.Count-1 do
if (ConversionScope in PFormatMap(FList[i])^.ConversionScopes) and
(PFormatMap(FList[i])^.DataFormat.InheritsFrom(DataFormatClass)) then
begin
ClipboardFormat := PFormatMap(FList[i])^.ClipboardFormat.Create;
ClipboardFormat.DataDirections := PFormatMap(FList[i])^.DataDirections;
ClipboardFormats.Add(ClipboardFormat);
end;
end;
procedure TDataFormatMap.RegisterFormatMap(DataFormatClass: TDataFormatClass;
ClipboardFormatClass: TClipboardFormatClass; Priority: integer;
ConversionScopes: TConversionScopes; DataDirections: TDataDirections);
begin
Add(DataFormatClass, ClipboardFormatClass, Priority, ConversionScopes,
DataDirections);
end;
procedure TDataFormatMap.UnregisterFormatMap(DataFormatClass: TDataFormatClass;
ClipboardFormatClass: TClipboardFormatClass);
begin
Delete(DataFormatClass, ClipboardFormatClass);
end;
var
FDataFormatMap: TDataFormatMap = nil;
class function TDataFormatMap.Instance: TDataFormatMap;
begin
if (FDataFormatMap = nil) then
FDataFormatMap := TDataFormatMap.Create;
Result := FDataFormatMap;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TDataFormatAdapter
//
////////////////////////////////////////////////////////////////////////////////
destructor TDataFormatAdapter.Destroy;
begin
inherited Destroy;
end;
function TDataFormatAdapter.GetDataFormatName: string;
begin
if Assigned(FDataFormatClass) then
Result := FDataFormatClass.ClassName
else
Result := '';
end;
function TDataFormatAdapter.GetEnabled: boolean;
begin
if (csDesigning in ComponentState) then
Result := FEnabled
else
Result := Assigned(FDataFormat) and Assigned(FDataFormatClass);
end;
procedure TDataFormatAdapter.Loaded;
begin
inherited;
if (FEnabled) then
Enabled := True;
end;
procedure TDataFormatAdapter.Notification(AComponent: TComponent;
Operation: TOperation);
begin
if (Operation = opRemove) and (AComponent = FDragDropComponent) then
DragDropComponent := nil;
inherited;
end;
procedure TDataFormatAdapter.SetDataFormatClass(const Value: TDataFormatClass);
begin
if (Value <> FDataFormatClass) then
begin
if not(csLoading in ComponentState) then
Enabled := False;
FDataFormatClass := Value;
end;
end;
procedure TDataFormatAdapter.SetDataFormatName(const Value: string);
var
i: integer;
ADataFormatClass: TDataFormatClass;
begin
ADataFormatClass := nil;
if (Value <> '') then
begin
for i := 0 to TDataFormatClasses.Instance.Count-1 do
if (AnsiCompareText(TDataFormatClasses.Instance[i].ClassName, Value) = 0) then
begin
ADataFormatClass := TDataFormatClasses.Instance[i];
break;
end;
if (ADataFormatClass = nil) then
raise Exception.CreateFmt(sUnregisteredDataFormat, [Value]);
end;
DataFormatClass := ADataFormatClass;
end;
procedure TDataFormatAdapter.SetDragDropComponent(const Value: TDragDropComponent);
begin
if (Value <> FDragDropComponent) then
begin
if not(csLoading in ComponentState) then
Enabled := False;
if (FDragDropComponent <> nil) then
FDragDropComponent.RemoveFreeNotification(Self);
FDragDropComponent := Value;
if (Value <> nil) then
Value.FreeNotification(Self);
end;
end;
procedure TDataFormatAdapter.SetEnabled(const Value: boolean);
begin
if (csLoading in ComponentState) then
begin
FEnabled := Value;
end else
if (csDesigning in ComponentState) then
begin
FEnabled := Value and Assigned(FDragDropComponent) and
Assigned(FDataFormatClass);
end else
if (Value) then
begin
if (Assigned(FDragDropComponent)) and (Assigned(FDataFormatClass)) and
(not Assigned(FDataFormat)) then
FDataFormat := FDataFormatClass.Create(FDragDropComponent);
end else
begin
if Assigned(FDataFormat) then
begin
if Assigned(FDragDropComponent) and
(FDragDropComponent.DataFormats.IndexOf(FDataFormat) <> -1) then
FDataFormat.Free;
FDataFormat := nil;
end;
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TRawClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
constructor TRawClipboardFormat.Create;
begin
// Yeah, it's a hack but blame Borland for making TObject.Create public!
raise Exception.CreateFmt(sBadConstructor, [ClassName]);
end;
constructor TRawClipboardFormat.CreateFormatEtc(const AFormatEtc: TFormatEtc);
begin
inherited CreateFormatEtc(AFormatEtc);
end;
procedure TRawClipboardFormat.SetClipboardFormatName(const Value: string);
begin
ClipboardFormat := RegisterClipboardFormat(PChar(Value));
end;
function TRawClipboardFormat.GetClipboardFormat: TClipFormat;
begin
Result := FFormatEtc.cfFormat;
end;
function TRawClipboardFormat.Assign(Source: TCustomDataFormat): boolean;
begin
if (Source is TRawDataFormat) then
begin
Result := True;
end else
Result := inherited Assign(Source);
end;
function TRawClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean;
begin
if (Dest is TRawDataFormat) then
begin
Result := True;
end else
Result := inherited AssignTo(Dest);
end;
procedure TRawClipboardFormat.Clear;
begin
// Since TRawDataFormat performs storage for TRawDataFormat we only allow
// TRawDataFormat to clear. To accomplish this TRawDataFormat ignores calls to
// the clear method and instead introduces the ClearData method.
end;
procedure TRawClipboardFormat.ClearData;
begin
ReleaseStgMedium(FMedium);
FillChar(FMedium, SizeOf(FMedium), 0);
end;
function TRawClipboardFormat.HasData: boolean;
begin
Result := (FMedium.tymed <> TYMED_NULL);
end;
function TRawClipboardFormat.NeedsData: boolean;
begin
Result := (FMedium.tymed = TYMED_NULL);
end;
procedure TRawClipboardFormat.CopyFromStgMedium(const AMedium: TStgMedium);
begin
CopyStgMedium(AMedium, FMedium);
end;
procedure TRawClipboardFormat.CopyToStgMedium(var AMedium: TStgMedium);
begin
CopyStgMedium(FMedium, AMedium);
end;
function TRawClipboardFormat.DoGetData(ADataObject: IDataObject;
const AMedium: TStgMedium): boolean;
begin
Result := CopyStgMedium(AMedium, FMedium);
end;
function TRawClipboardFormat.DoSetData(const FormatEtcIn: TFormatEtc;
var AMedium: TStgMedium): boolean;
begin
Result := CopyStgMedium(FMedium, AMedium);
end;
function TRawClipboardFormat.GetString: string;
begin
with TTextClipboardFormat.Create do
try
if GetDataFromMedium(nil, FMedium) then
Result := Text
else
Result := '';
finally
Free;
end;
end;
procedure TRawClipboardFormat.SetString(const Value: string);
begin
with TTextClipboardFormat.Create do
try
Text := Value;
SetDataToMedium(FormatEtc, FMedium);
finally
Free;
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TRawDataFormat
//
////////////////////////////////////////////////////////////////////////////////
procedure TRawDataFormat.Clear;
var
i: integer;
begin
Changing;
for i := 0 to CompatibleFormats.Count-1 do
TRawClipboardFormat(CompatibleFormats[i]).ClearData;
end;
function TRawDataFormat.HasData: boolean;
var
i: integer;
begin
i := 0;
Result := False;
while (not Result) and (i < CompatibleFormats.Count) do
begin
Result := TRawClipboardFormat(CompatibleFormats[i]).HasData;
inc(i);
end;
end;
function TRawDataFormat.NeedsData: boolean;
var
i: integer;
begin
i := 0;
Result := False;
while (not Result) and (i < CompatibleFormats.Count) do
begin
Result := TRawClipboardFormat(CompatibleFormats[i]).NeedsData;
inc(i);
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// Utility functions
//
////////////////////////////////////////////////////////////////////////////////
procedure _RaiseLastWin32Error;
begin
{$ifdef VER14_PLUS}
RaiseLastOSError;
{$else}
RaiseLastWin32Error;
{$endif}
end;
function DropEffectToDragType(DropEffect: longInt; var DragType: TDragType): boolean;
begin
Result := True;
if ((DropEffect and DROPEFFECT_COPY) <> 0) then
DragType := dtCopy
else
if ((DropEffect and DROPEFFECT_MOVE) <> 0) then
DragType := dtMove
else
if ((DropEffect and DROPEFFECT_LINK) <> 0) then
DragType := dtLink
else
begin
DragType := dtCopy;
Result := False;
end;
end;
function DragTypesToDropEffect(DragTypes: TDragTypes): longint;
begin
Result := DROPEFFECT_NONE;
if (dtCopy in DragTypes) then
Result := Result OR DROPEFFECT_COPY;
if (dtMove in DragTypes) then
Result := Result OR DROPEFFECT_MOVE;
if (dtLink in DragTypes) then
Result := Result OR DROPEFFECT_LINK;
end;
// Replacement for the buggy DragDetect API function.
function DragDetectPlus(Handle: THandle; p: TPoint): boolean;
var
DragRect: TRect;
Msg: TMsg;
StartTime: DWORD;
OldCapture: HWND;
begin
Result := False;
if (not ClientToScreen(Handle, p)) then
exit;
// Calculate the drag rect. If the mouse leaves this rect while the
// mouse button is pressed, a drag is detected.
DragRect.TopLeft := p;
DragRect.BottomRight := p;
InflateRect(DragRect, GetSystemMetrics(SM_CXDRAG), GetSystemMetrics(SM_CYDRAG));
StartTime := TimeGetTime;
// Capture the mouse so that we will receive mouse messages even after the
// mouse leaves the control rect.
OldCapture := SetCapture(Handle);
try
// Abort if we failed to capture the mouse.
if (GetCapture <> Handle) then
exit;
while (not Result) do
begin
// Detect if all mouse buttons are up (might mean that we missed a
// MW_?BUTTONUP message).
if (GetAsyncKeyState(VK_LBUTTON) AND $8000 = 0) and
(GetAsyncKeyState(VK_RBUTTON) AND $8000 = 0) then
break;
if (PeekMessage(Msg, Handle, 0,0, PM_REMOVE)) then
begin
case (Msg.message) of
WM_MOUSEMOVE:
// Mouse were moved. Check if we are still within the drag rect...
Result := (not PtInRect(DragRect, Msg.pt)) and
// ... and that the minimum time has elapsed.
// Note that we ignore time warp (wrap around) and that Msg.Time
// might be smaller than StartTime.
(Msg.time >= StartTime + DWORD(DragDropDragDelay));
WM_RBUTTONUP,
WM_LBUTTONUP,
WM_CANCELMODE:
// Mouse button were released, escape were pressed or some other
// operation cancelled our mouse capture.
break;
WM_QUIT:
// Application is shutting down. Get out of here fast.
exit;
else
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end else
Sleep(0);
end;
finally
ReleaseCapture;
// Restore previous capture.
if (OldCapture <> 0) then
SetCapture(OldCapture);
end;
end;
function ClientPtToWindowPt(Handle: THandle; pt: TPoint): TPoint;
var
Rect: TRect;
begin
ClientToScreen(Handle, pt);
GetWindowRect(Handle, Rect);
Result.X := pt.X - Rect.Left;
Result.Y := pt.Y - Rect.Top;
end;
const
// Note: The definition of MK_ALT is missing from the current Delphi (D5)
// declarations. Hopefully Delphi 6 will fix this.
MK_ALT = $20;
function KeysToShiftStatePlus(Keys: Word): TShiftState;
begin
Result := [];
if (Keys and MK_SHIFT <> 0) then
Include(Result, ssShift);
if (Keys and MK_CONTROL <> 0) then
Include(Result, ssCtrl);
if (Keys and MK_LBUTTON <> 0) then
Include(Result, ssLeft);
if (Keys and MK_RBUTTON <> 0) then
Include(Result, ssRight);
if (Keys and MK_MBUTTON <> 0) then
Include(Result, ssMiddle);
if (Keys and MK_ALT <> 0) then
Include(Result, ssMiddle);
end;
function ShiftStateToDropEffect(Shift: TShiftState; AllowedEffects: longint;
Fallback: boolean): longint;
begin
// As we're only interested in ssShift & ssCtrl here,
// mouse button states are screened out.
Shift := Shift * [ssShift, ssCtrl];
Result := DROPEFFECT_NONE;
if (Shift = [ssShift, ssCtrl]) then
begin
if (AllowedEffects AND DROPEFFECT_LINK <> 0) then
Result := DROPEFFECT_LINK;
end else
if (Shift = [ssCtrl]) then
begin
if (AllowedEffects AND DROPEFFECT_COPY <> 0) then
Result := DROPEFFECT_COPY;
end else
begin
if (AllowedEffects AND DROPEFFECT_MOVE <> 0) then
Result := DROPEFFECT_MOVE;
end;
// Fall back to defaults if the shift-states specified an
// unavailable drop effect.
if (Result = DROPEFFECT_NONE) and (Fallback) then
begin
if (AllowedEffects AND DROPEFFECT_COPY <> 0) then
Result := DROPEFFECT_COPY
else if (AllowedEffects AND DROPEFFECT_MOVE <> 0) then
Result := DROPEFFECT_MOVE
else if (AllowedEffects AND DROPEFFECT_LINK <> 0) then
Result := DROPEFFECT_LINK;
end;
end;
var
URLMONDLL: THandle = 0;
_CopyStgMedium: function(const cstgmedSrc: TStgMedium; var stgmedDest: TStgMedium): HResult; stdcall = nil;
function CopyStgMedium(const SrcMedium: TStgMedium; var DstMedium: TStgMedium): boolean;
begin
// Copy the medium via the URLMON CopyStgMedium function. This should be safe
// since this function is only called when the drag drop helper object is
// used and the drag drop helper object is only supported on Windows 2000
// and later.
// URLMON.CopyStgMedium requires IE4 or later.
// An alternative approach would be to use OleDuplicateData, but based on a
// disassembly of urlmon.dll, CopyStgMedium seems to do a lot more than
// OleDuplicateData.
if (URLMONDLL = 0) then
begin
URLMONDLL := LoadLibrary('URLMON.DLL');
if (URLMONDLL <> 0) then
@_CopyStgMedium := GetProcAddress(URLMONDLL, 'CopyStgMedium');
end;
if (@_CopyStgMedium = nil) then
raise Exception.Create(sNoCopyStgMedium);
Result := (_CopyStgMedium(SrcMedium, DstMedium) = S_OK);
end;
function GetClipboardFormatNameStr(Value: TClipFormat): string;
var
len: integer;
begin
Setlength(Result, 255);
len := GetClipboardFormatName(Value, PChar(Result), 255);
SetLength(Result, len);
end;
////////////////////////////////////////////////////////////////////////////////
//
// Initialization/Finalization
//
////////////////////////////////////////////////////////////////////////////////
initialization
OleInitialize(nil);
ShGetMalloc(ShellMalloc);
GetClipboardFormatNameStr(0);
finalization
if (FDataFormatMap <> nil) then
begin
FDataFormatMap.Free;
FDataFormatMap := nil;
end;
if (FDataFormatClasses <> nil) then
begin
FDataFormatClasses.Free;
FDataFormatClasses := nil;
end;
ShellMalloc := nil;
OleUninitialize;
end.