Subversion Repositories decoder

Rev

Blame | Last modification | View Log | RSS feed

  1. unit DragDrop;
  2. // -----------------------------------------------------------------------------
  3. // Project:         Drag and Drop Component Suite
  4. // Module:          DragDrop
  5. // Description:     Implements base classes and utility functions.
  6. // Version:         4.0
  7. // Date:            18-MAY-2001
  8. // Target:          Win32, Delphi 5-6
  9. // Authors:         Anders Melander, anders@melander.dk, http://www.melander.dk
  10. // Copyright        © 1997-2001 Angus Johnson & Anders Melander
  11. // -----------------------------------------------------------------------------
  12. // TODO -oanme -cPortability : Replace all public use of HWND with THandle. BCB's HWND <> Delphi's HWND.
  13. {$include DragDrop.inc}
  14.  
  15. interface
  16.  
  17. uses
  18.   Classes,
  19.   Windows,
  20.   ActiveX;
  21.  
  22. {$IFDEF BCB}
  23. {$HPPEMIT '#ifndef NO_WIN32_LEAN_AND_MEAN'}
  24. {$HPPEMIT '"Error: The NO_WIN32_LEAN_AND_MEAN symbol must be defined in your projects conditional defines"'}
  25. {$HPPEMIT '#endif'}
  26. {$ENDIF}
  27.  
  28.  
  29. const
  30.   DROPEFFECT_NONE   = ActiveX.DROPEFFECT_NONE;
  31.   DROPEFFECT_COPY   = ActiveX.DROPEFFECT_COPY;
  32.   DROPEFFECT_MOVE   = ActiveX.DROPEFFECT_MOVE;
  33.   DROPEFFECT_LINK   = ActiveX.DROPEFFECT_LINK;
  34.   DROPEFFECT_SCROLL = ActiveX.DROPEFFECT_SCROLL;
  35.  
  36. type
  37.   // TDragType enumerates the three possible drag/drop operations.
  38.   TDragType = (dtCopy, dtMove, dtLink);
  39.   TDragTypes = set of TDragType;
  40.  
  41. type
  42.   // TDataDirection is used by the clipboard format registration to specify
  43.   // if the clipboard format should be listed in get (read) format enumerations,
  44.   // set (write) format enumerations or both.
  45.   // ddRead : Destination (IDropTarget) can read data from IDataObject.
  46.   // ddWrite : Destination (IDropTarget) can write data to IDataObject.
  47.   TDataDirection = (ddRead, ddWrite);
  48.   TDataDirections = set of TDataDirection;
  49.  
  50. const
  51.   ddReadWrite = [ddRead, ddWrite];
  52.  
  53. type
  54.   // TConversionScope is used by the clipboard format registration to specify
  55.   // if a clipboard format conversion is supported by the drop source, the drop
  56.   // target or both.
  57.   // ddSource : Conversion is valid for drop source (IDropSource).
  58.   // ddTarget : Conversion is valid for drop target (IDropTarget).
  59.   TConversionScope = (csSource, csTarget);
  60.   TConversionScopes = set of TConversionScope;
  61.  
  62. const
  63.   csSourceTarget = [csSource, csTarget];
  64.  
  65. // C++ Builder's declaration of IEnumFORMATETC is incorrect, so we must generate
  66. // the typedef for C++ Builder.
  67. {$IFDEF BCB}
  68. {$HPPEMIT 'typedef System::DelphiInterface<IEnumFORMATETC> _di_IEnumFORMATETC;' }
  69. {$ENDIF}
  70.  
  71. ////////////////////////////////////////////////////////////////////////////////
  72. //
  73. //              TInterfacedComponent
  74. //
  75. ////////////////////////////////////////////////////////////////////////////////
  76. // Top level base class for the drag/drop component hierachy.
  77. // Implements the IUnknown interface.
  78. // Corresponds to TInterfacedObject (see VCL on-line help), but descends from
  79. // TComponent instead of TObject.
  80. // Reference counting is disabled (_AddRef and _Release methods does nothing)
  81. // since the component life span is controlled by the component owner.
  82. ////////////////////////////////////////////////////////////////////////////////
  83. type
  84.   TInterfacedComponent = class(TComponent, IUnknown)
  85.   protected
  86.     function QueryInterface(const IID: TGuid; out Obj): HRESULT;
  87.       {$IFDEF VER13_PLUS} override; {$ELSE}
  88.       {$IFDEF VER12_PLUS} reintroduce; {$ENDIF}{$ENDIF} stdcall;
  89.     function _AddRef: Integer; stdcall;
  90.     function _Release: Integer; stdcall;
  91.   end;
  92.  
  93. ////////////////////////////////////////////////////////////////////////////////
  94. //
  95. //              TClipboardFormat
  96. //
  97. ////////////////////////////////////////////////////////////////////////////////
  98. // Abstract base class. Extracts or injects data of a specific low level format
  99. // from or to an IDataObject.
  100. ////////////////////////////////////////////////////////////////////////////////
  101. type
  102.   TCustomDataFormat = class;
  103.  
  104.   TClipboardFormat = class(TObject)
  105.   private
  106.     FDataDirections: TDataDirections;
  107.     FDataFormat: TCustomDataFormat;
  108.   protected
  109.     FFormatEtc: TFormatEtc;
  110.     constructor CreateFormat(Atymed: Longint); virtual;
  111.     constructor CreateFormatEtc(const AFormatEtc: TFormatEtc); virtual;
  112.     { Extracts data from the specified medium }
  113.     function DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean; virtual;
  114.     { Transfer data to the specified medium }
  115.     function DoSetData(const FormatEtcIn: TFormatEtc;
  116.       var AMedium: TStgMedium): boolean; virtual;
  117.     function GetClipboardFormat: TClipFormat; virtual;
  118.     procedure SetClipboardFormat(Value: TClipFormat); virtual;
  119.     function GetClipboardFormatName: string; virtual;
  120.     procedure SetClipboardFormatName(const Value: string); virtual;
  121.     procedure SetFormatEtc(const Value: TFormatEtc);
  122.   public
  123.     constructor Create; virtual; abstract;
  124.     destructor Destroy; override;
  125.     { Determines if the object can read from the specified data object }
  126.     function HasValidFormats(ADataObject: IDataObject): boolean; virtual;
  127.     { Determines if the object can read the specified format }
  128.     function AcceptFormat(const AFormatEtc: TFormatEtc): boolean; virtual;
  129.     { Extracts data from the specified IDataObject }
  130.     function GetData(ADataObject: IDataObject): boolean; virtual;
  131.     { Extracts data from the specified IDataObject via the specified medium }
  132.     function GetDataFromMedium(ADataObject: IDataObject;
  133.       var AMedium: TStgMedium): boolean; virtual;
  134.     { Transfers data to the specified IDataObject }
  135.     function SetData(ADataObject: IDataObject; const FormatEtcIn: TFormatEtc;
  136.       var AMedium: TStgMedium): boolean; virtual;
  137.     { Transfers data to the specified medium }
  138.     function SetDataToMedium(const FormatEtcIn: TFormatEtc;
  139.       var AMedium: TStgMedium): boolean;
  140.     { Copies data from the specified source format to the object }
  141.     function Assign(Source: TCustomDataFormat): boolean; virtual;
  142.     { Copies data from the object to the specified target format }
  143.     function AssignTo(Dest: TCustomDataFormat): boolean; virtual;
  144.     { Clears the objects data }
  145.     procedure Clear; virtual; abstract;
  146.     { Returns true if object can supply data }
  147.     function HasData: boolean; virtual;
  148.     { Unregisters the clipboard format and all mappings involving it from the global database }
  149.     class procedure UnregisterClipboardFormat;
  150.     { Returns the clipboard format value }
  151.     property ClipboardFormat: TClipFormat read GetClipboardFormat
  152.       write SetClipboardFormat;
  153.     { Returns the clipboard format name }
  154.     property ClipboardFormatName: string read GetClipboardFormatName
  155.       write SetClipboardFormatName;
  156.     { Provides access to the objects format specification }
  157.     property FormatEtc: TFormatEtc read FFormatEtc;
  158.     { Specifies whether the format can read and write data }
  159.     property DataDirections: TDataDirections read FDataDirections
  160.       write FDataDirections;
  161.     { Specifies the data format which owns and controls this clipboard format }
  162.     property DataFormat: TCustomDataFormat read FDataFormat write FDataFormat;
  163.   end;
  164.  
  165.   TClipboardFormatClass = class of TClipboardFormat;
  166.  
  167.   // TClipboardFormats
  168.   // List of TClipboardFormat objects.
  169.   TClipboardFormats = class(TObject)
  170.   private
  171.     FList: TList;
  172.     FOwnsObjects: boolean;
  173.     FDataFormat: TCustomDataFormat;
  174.   protected
  175.     function GetFormat(Index: integer): TClipboardFormat;
  176.     function GetCount: integer;
  177.   public
  178.     constructor Create(ADataFormat: TCustomDataFormat; AOwnsObjects: boolean);
  179.     destructor Destroy; override;
  180.     procedure Clear;
  181.     function Add(ClipboardFormat: TClipboardFormat): integer;
  182.     function Contain(ClipboardFormatClass: TClipboardFormatClass): boolean;
  183.     function FindFormat(ClipboardFormatClass: TClipboardFormatClass): TClipboardFormat;
  184.     property Formats[Index: integer]: TClipboardFormat read GetFormat; default;
  185.     property Count: integer read GetCount;
  186.     property DataFormat: TCustomDataFormat read FDataFormat;
  187.   end;
  188.  
  189. ////////////////////////////////////////////////////////////////////////////////
  190. //
  191. //              TDragDropComponent
  192. //
  193. ////////////////////////////////////////////////////////////////////////////////
  194. // Base class for drag/drop components.
  195. ////////////////////////////////////////////////////////////////////////////////
  196.   TDataFormats = class;
  197.  
  198.   TDragDropComponent = class(TInterfacedComponent)
  199.   private
  200.   protected
  201.     FDataFormats: TDataFormats;
  202.     //: Only used by TCustomDropMultiSource and TCustomDropMultiTarget and
  203.     // their descendants.
  204.     property DataFormats: TDataFormats read FDataFormats;
  205.   public
  206.   end;
  207.  
  208. ////////////////////////////////////////////////////////////////////////////////
  209. //
  210. //              TCustomFormat
  211. //
  212. ////////////////////////////////////////////////////////////////////////////////
  213. // Abstract base class.
  214. // Renders the data of one or more TClipboardFormat objects to or from a
  215. // specific high level data format.
  216. ////////////////////////////////////////////////////////////////////////////////
  217.   TCustomDataFormat = class(TObject)
  218.   private
  219.     FCompatibleFormats  : TClipboardFormats;
  220.     FFormatList         : TDataFormats;
  221.     FOwner              : TDragDropComponent;
  222.     FOnChanging         : TNotifyEvent;
  223.   protected
  224.     { Determines if the object can accept data from the specified source format }
  225.     function SupportsFormat(ClipboardFormat: TClipboardFormat): boolean;
  226.     procedure DoOnChanging(Sender: TObject);
  227.     procedure Changing; virtual;
  228.     property FormatList: TDataFormats read FFormatList;
  229.   public
  230.     constructor Create(AOwner: TDragDropComponent); virtual;
  231.     destructor Destroy; override;
  232.     procedure Clear; virtual; abstract;
  233.     { Copies data between the specified clipboard format to the object }
  234.     function Assign(Source: TClipboardFormat): boolean; virtual;
  235.     function AssignTo(Dest: TClipboardFormat): boolean; virtual;
  236.     { Extracts data from the specified IDataObject }
  237.     function GetData(DataObject: IDataObject): boolean; virtual;
  238.     { Determines if the object contains *any* data }
  239.     function HasData: boolean; virtual; abstract;
  240.     { Determines if the object needs/can use *more* data }
  241.     function NeedsData: boolean; virtual;
  242.     { Determines if the object can read from the specified data object }
  243.     function HasValidFormats(ADataObject: IDataObject): boolean; virtual;
  244.     { Determines if the object can read the specified format }
  245.     function AcceptFormat(const FormatEtc: TFormatEtc): boolean; virtual;
  246.     { Registers the data format in the data format list }
  247.     class procedure RegisterDataFormat;
  248.     { Registers the specified clipboard format as being compatible with the data format }
  249.     class procedure RegisterCompatibleFormat(ClipboardFormatClass: TClipboardFormatClass;
  250.       Priority: integer {$ifdef VER12_PLUS} = 0 {$endif};
  251.       ConversionScopes: TConversionScopes {$ifdef VER12_PLUS} = csSourceTarget {$endif};
  252.       DataDirections: TDataDirections {$ifdef VER12_PLUS} = [ddRead] {$endif});
  253.     { Unregisters the specified clipboard format from the compatibility list }
  254.     class procedure UnregisterCompatibleFormat(ClipboardFormatClass: TClipboardFormatClass);
  255.     { Unregisters data format and all mappings involving it from the global database }
  256.     class procedure UnregisterDataFormat;
  257.     { List of compatible source formats }
  258.     property CompatibleFormats: TClipboardFormats read FCompatibleFormats;
  259.     property Owner: TDragDropComponent read FOwner;
  260.     property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  261.     // TODO : Add support for delayed rendering with DelayedRender property.
  262.   end;
  263.  
  264.   // TDataFormats
  265.   // List of TCustomDataFormat objects.
  266.   TDataFormats = class(TObject)
  267.   private
  268.     FList: TList;
  269.   protected
  270.     function GetFormat(Index: integer): TCustomDataFormat;
  271.     function GetCount: integer;
  272.   public
  273.     constructor Create;
  274.     destructor Destroy; override;
  275.     function Add(DataFormat: TCustomDataFormat): integer; virtual;
  276.     function IndexOf(DataFormat: TCustomDataFormat): integer; virtual;
  277.     procedure Remove(DataFormat: TCustomDataFormat); virtual;
  278.     property Formats[Index: integer]: TCustomDataFormat read GetFormat; default;
  279.     property Count: integer read GetCount;
  280.   end;
  281.  
  282.   // TDataFormatClasses
  283.   // List of TCustomDataFormat classes.
  284.   TDataFormatClass = class of TCustomDataFormat;
  285.  
  286.   TDataFormatClasses = class(TObject)
  287.   private
  288.     FList: TList;
  289.   protected
  290.     function GetFormat(Index: integer): TDataFormatClass;
  291.     function GetCount: integer;
  292.     { Provides singleton access to the global data format database }
  293.     class function Instance: TDataFormatClasses;
  294.   public
  295.     constructor Create;
  296.     destructor Destroy; override;
  297.     function Add(DataFormat: TDataFormatClass): integer; virtual;
  298.     procedure Remove(DataFormat: TDataFormatClass); virtual;
  299.     property Formats[Index: integer]: TDataFormatClass read GetFormat; default;
  300.     property Count: integer read GetCount;
  301.   end;
  302.  
  303.   // TDataFormatMap
  304.   // Format conversion database. Contains mappings between TClipboardFormat
  305.   // and TCustomDataFormat.
  306.   // Used internally by TCustomDropMultiTarget and TCustomDropMultiSource.
  307.   TDataFormatMap = class(TObject)
  308.     FList: TList;
  309.   protected
  310.     function FindMap(DataFormatClass: TDataFormatClass; ClipboardFormatClass: TClipboardFormatClass): integer;
  311.     procedure Sort;
  312.     { Provides singleton access to the global format map database }
  313.     class function Instance: TDataFormatMap;
  314.   public
  315.     constructor Create;
  316.     destructor Destroy; override;
  317.     procedure Add(DataFormatClass: TDataFormatClass;
  318.       ClipboardFormatClass: TClipboardFormatClass;
  319.       Priority: integer {$ifdef VER12_PLUS} = 0 {$endif};
  320.       ConversionScopes: TConversionScopes {$ifdef VER12_PLUS} = csSourceTarget {$endif};
  321.       DataDirections: TDataDirections {$ifdef VER12_PLUS} = [ddRead] {$endif});
  322.     procedure Delete(DataFormatClass: TDataFormatClass;
  323.       ClipboardFormatClass: TClipboardFormatClass);
  324.     procedure DeleteByClipboardFormat(ClipboardFormatClass: TClipboardFormatClass);
  325.     procedure DeleteByDataFormat(DataFormatClass: TDataFormatClass);
  326.     procedure GetSourceByDataFormat(DataFormatClass: TDataFormatClass;
  327.       ClipboardFormats: TClipboardFormats; ConversionScope: TConversionScope);
  328.     function CanMap(DataFormatClass: TDataFormatClass;
  329.       ClipboardFormatClass: TClipboardFormatClass): boolean;
  330.  
  331.     { Registers the specified format mapping }
  332.     procedure RegisterFormatMap(DataFormatClass: TDataFormatClass;
  333.       ClipboardFormatClass: TClipboardFormatClass;
  334.       Priority: integer {$ifdef VER12_PLUS} = 0 {$endif};
  335.       ConversionScopes: TConversionScopes {$ifdef VER12_PLUS} = csSourceTarget {$endif};
  336.       DataDirections: TDataDirections {$ifdef VER12_PLUS} = [ddRead] {$endif});
  337.     { Unregisters the specified format mapping }
  338.     procedure UnregisterFormatMap(DataFormatClass: TDataFormatClass;
  339.       ClipboardFormatClass: TClipboardFormatClass);
  340.   end;
  341.  
  342. ////////////////////////////////////////////////////////////////////////////////
  343. //
  344. //              TDataFormatAdapter
  345. //
  346. ////////////////////////////////////////////////////////////////////////////////
  347. // Helper component used to add additional data formats to a drop source or
  348. // target at design time.
  349. // Requires that data formats have been registered with
  350. // TCustomDataFormat.RegisterDataFormat.
  351. ////////////////////////////////////////////////////////////////////////////////
  352.   TDataFormatAdapter = class(TComponent)
  353.   private
  354.     FDragDropComponent: TDragDropComponent;
  355.     FDataFormat: TCustomDataFormat;
  356.     FDataFormatClass: TDataFormatClass;
  357.     FEnabled: boolean;
  358.     function GetDataFormatName: string;
  359.     procedure SetDataFormatName(const Value: string);
  360.   protected
  361.     procedure SetDataFormatClass(const Value: TDataFormatClass);
  362.     procedure SetDragDropComponent(const Value: TDragDropComponent);
  363.     function GetEnabled: boolean;
  364.     procedure SetEnabled(const Value: boolean);
  365.     procedure Notification(AComponent: TComponent;
  366.       Operation: TOperation); override;
  367.     procedure Loaded; override;
  368.   public
  369.     destructor Destroy; override;
  370.     property DataFormatClass: TDataFormatClass read FDataFormatClass
  371.       write SetDataFormatClass;
  372.     property DataFormat: TCustomDataFormat read FDataFormat;
  373.   published
  374.     property DragDropComponent: TDragDropComponent read FDragDropComponent
  375.       write SetDragDropComponent;
  376.     property DataFormatName: string read GetDataFormatName
  377.       write SetDataFormatName;
  378.     property Enabled: boolean read GetEnabled write SetEnabled;
  379.   end;
  380.  
  381. ////////////////////////////////////////////////////////////////////////////////
  382. //
  383. //              Drag Drop helper interfaces
  384. //
  385. ////////////////////////////////////////////////////////////////////////////////
  386. // Requires Windows 2000 or later.
  387. ////////////////////////////////////////////////////////////////////////////////
  388. type
  389.   PSHDRAGIMAGE = ^TSHDRAGIMAGE;
  390.   {_$EXTERNALSYM _SHDRAGIMAGE}
  391.   _SHDRAGIMAGE = packed record
  392.     sizeDragImage: TSize;               { The length and Width of the rendered image }
  393.     ptOffset: TPoint;                   { The Offset from the mouse cursor to the upper left corner of the image }
  394.     hbmpDragImage: HBitmap;             { The Bitmap containing the rendered drag images }
  395.     crColorKey: COLORREF;               { The COLORREF that has been blitted to the background of the images }
  396.   end;
  397.   TSHDRAGIMAGE = _SHDRAGIMAGE;
  398.   {_$EXTERNALSYM SHDRAGIMAGE}
  399.   SHDRAGIMAGE = _SHDRAGIMAGE;
  400.  
  401. const
  402.   CLSID_DragDropHelper: TGUID = (
  403.     D1:$4657278a; D2:$411b; D3:$11d2; D4:($83,$9a,$00,$c0,$4f,$d9,$18,$d0));
  404.   SID_DragDropHelper = '{4657278A-411B-11d2-839A-00C04FD918D0}';
  405.  
  406. const
  407.   IID_IDropTargetHelper: TGUID = (
  408.     D1:$4657278b; D2:$411b; D3:$11d2; D4:($83,$9a,$00,$c0,$4f,$d9,$18,$d0));
  409.   SID_IDropTargetHelper = '{4657278B-411B-11d2-839A-00C04FD918D0}';
  410.  
  411. type
  412.   {_$HPPEMIT 'typedef DragDrop::DelphiInterface<IDropTargetHelper> _di_IDropTargetHelper;'}
  413.   {_$EXTERNALSYM IDropTargetHelper}
  414.   IDropTargetHelper = interface(IUnknown)
  415.     [SID_IDropTargetHelper]
  416.     function DragEnter(hwndTarget: HWND; const DataObj: IDataObject;
  417.       var pt: TPoint; dwEffect: Longint): HResult; stdcall;
  418.     function DragLeave: HResult; stdcall;
  419.     function DragOver(var pt: TPoint; dwEffect: longInt): HResult; stdcall;
  420.     function Drop(const DataObj: IDataObject; var pt: TPoint;
  421.       dwEffect: longInt): HResult; stdcall;
  422.     function Show(Show: BOOL): HResult; stdcall;
  423.   end;
  424.  
  425. const
  426.   IID_IDragSourceHelper: TGUID = (
  427.     D1:$de5bf786; D2:$477a; D3:$11d2; D4:($83,$9d,$00,$c0,$4f,$d9,$18,$d0));
  428.   SID_IDragSourceHelper = '{DE5BF786-477A-11d2-839D-00C04FD918D0}';
  429.  
  430. type
  431.   {_$HPPEMIT 'typedef DragDrop::DelphiInterface<IDragSourceHelper> _di_IDragSourceHelper;'}
  432.   {_$EXTERNALSYM IDragSourceHelper}
  433.   IDragSourceHelper = interface(IUnknown)
  434.     [SID_IDragSourceHelper]
  435.     function InitializeFromBitmap(var shdi: TSHDRAGIMAGE;
  436.       const DataObj: IDataObject): HResult; stdcall;
  437.     function InitializeFromWindow(hwnd: HWND; var pt: TPoint;
  438.       const DataObj: IDataObject): HResult; stdcall;
  439.   end;
  440.  
  441. ////////////////////////////////////////////////////////////////////////////////
  442. //
  443. //              Async data transfer interfaces
  444. //
  445. ////////////////////////////////////////////////////////////////////////////////
  446. // Requires Windows 2000 or later.
  447. ////////////////////////////////////////////////////////////////////////////////
  448. const
  449.   IID_IAsyncOperation: TGUID = (
  450.     D1:$3D8B0590; D2:$F691; D3:$11D2; D4:($8E,$A9,$00,$60,$97,$DF,$5B,$D4));
  451.   SID_IAsyncOperation = '{3D8B0590-F691-11D2-8EA9-006097DF5BD4}';
  452.  
  453. type
  454.   {_$HPPEMIT 'typedef DragDrop::DelphiInterface<IAsyncOperation> _di_IAsyncOperation;'}
  455.   {_$EXTERNALSYM IAsyncOperation}
  456.   IAsyncOperation = interface(IUnknown)
  457.     [SID_IAsyncOperation]
  458.     function SetAsyncMode(fDoOpAsync: BOOL): HResult; stdcall;
  459.     function GetAsyncMode(out fDoOpAsync: BOOL): HResult; stdcall;
  460.     function StartOperation(const pbcReserved: IBindCtx): HResult; stdcall;
  461.     function InOperation(out pfInAsyncOp: BOOL): HResult; stdcall;
  462.     function EndOperation(hResult: HRESULT; const pbcReserved: IBindCtx;
  463.       dwEffects: DWORD): HResult; stdcall;
  464.   end;
  465.  
  466. ////////////////////////////////////////////////////////////////////////////////
  467. //
  468. //              TRawClipboardFormat & TRawDataFormat
  469. //
  470. ////////////////////////////////////////////////////////////////////////////////
  471. // These clipboard and data format classes are special in that they don't
  472. // interpret the data in any way.
  473. // Their primary purpose is to enable the TCustomDropMultiSource class to accept
  474. // and store arbitrary (and unknown) data types. This is a requirement for
  475. // drag drop helper object support.
  476. ////////////////////////////////////////////////////////////////////////////////
  477. // The TRawDataFormat class does not perform any storage of data itself. Instead
  478. // it relies on the TRawClipboardFormat objects to store data.
  479. ////////////////////////////////////////////////////////////////////////////////
  480.   TRawDataFormat = class(TCustomDataFormat)
  481.   private
  482.     FMedium: TStgMedium;
  483.   protected
  484.   public
  485.     procedure Clear; override;
  486.     function HasData: boolean; override;
  487.     function NeedsData: boolean; override;
  488.     property Medium: TStgMedium read FMedium write FMedium;
  489.   end;
  490.  
  491.   TRawClipboardFormat = class(TClipboardFormat)
  492.   private
  493.     FMedium: TStgMedium;
  494.   protected
  495.     function DoGetData(ADataObject: IDataObject;
  496.       const AMedium: TStgMedium): boolean; override;
  497.     function DoSetData(const FormatEtcIn: TFormatEtc;
  498.       var AMedium: TStgMedium): boolean; override;
  499.     procedure SetClipboardFormatName(const Value: string); override;
  500.     function GetClipboardFormat: TClipFormat; override;
  501.     function GetString: string;
  502.     procedure SetString(const Value: string);
  503.   public
  504.     constructor Create; override;
  505.     constructor CreateFormatEtc(const AFormatEtc: TFormatEtc); override;
  506.     function Assign(Source: TCustomDataFormat): boolean; override;
  507.     function AssignTo(Dest: TCustomDataFormat): boolean; override;
  508.     procedure Clear; override;
  509.     // Methods to handle the corresponding TRawDataFormat functioinality.
  510.     procedure ClearData;
  511.     function HasData: boolean; override;
  512.     function NeedsData: boolean;
  513.  
  514.     // All of these should be moved/mirrored in TRawDataFormat:
  515.     procedure CopyFromStgMedium(const AMedium: TStgMedium);
  516.     procedure CopyToStgMedium(var AMedium: TStgMedium);
  517.     property AsString: string read GetString write SetString;
  518.     property Medium: TStgMedium read FMedium write FMedium;
  519.   end;
  520.  
  521. ////////////////////////////////////////////////////////////////////////////////
  522. //
  523. //              Utility functions
  524. //
  525. ////////////////////////////////////////////////////////////////////////////////
  526. function DropEffectToDragType(DropEffect: longInt; var DragType: TDragType): boolean;
  527. function DragTypesToDropEffect(DragTypes: TDragTypes): longint; // V4: New
  528.  
  529. // Coordinate space conversion.
  530. function ClientPtToWindowPt(Handle: THandle; pt: TPoint): TPoint;
  531.  
  532. // Replacement for KeysToShiftState.
  533. function KeysToShiftStatePlus(Keys: Word): TShiftState; // V4: New
  534. function ShiftStateToDropEffect(Shift: TShiftState; AllowedEffects: longint;
  535.   Fallback: boolean): longint;
  536.  
  537. // Replacement for the buggy DragDetect API function.
  538. function DragDetectPlus(Handle: THandle; p: TPoint): boolean; // V4: New
  539.  
  540. // Wrapper for urlmon.CopyStgMedium.
  541. // Note: Only works with IE4 or later installed.
  542. function CopyStgMedium(const SrcMedium: TStgMedium; var DstMedium: TStgMedium): boolean;
  543.  
  544. // Get the name of a clipboard format as a Delphi string.
  545. function GetClipboardFormatNameStr(Value: TClipFormat): string;
  546.  
  547. // Raise last Windows API error as an exception.
  548. procedure _RaiseLastWin32Error;
  549.  
  550. ////////////////////////////////////////////////////////////////////////////////
  551. //
  552. //              Global variables
  553. //
  554. ////////////////////////////////////////////////////////////////////////////////
  555. var
  556.   ShellMalloc: IMalloc;
  557.  
  558. // Name of the IDE component palette page the drag drop components are
  559. // registered to
  560. var
  561.   DragDropComponentPalettePage: string = 'DragDrop';
  562.  
  563. ////////////////////////////////////////////////////////////////////////////////
  564. //
  565. //              Misc drop target related constants
  566. //
  567. ////////////////////////////////////////////////////////////////////////////////
  568. // Drag Drop constants from ActiveX unit
  569. var
  570.   // Default inset-width of the auto scroll hot zone.
  571.   // Specified in pixels.
  572.   // Not used! Instead the height of the target control's font is used.
  573.   DragDropScrollInset: integer = DD_DEFSCROLLINSET; // 11
  574.  
  575.   // Default delay after entering the scroll zone, before scrolling starts.
  576.   // Specified in milliseconds.
  577.   DragDropScrollDelay: integer = DD_DEFSCROLLDELAY; //  50
  578.  
  579.   // Default scroll interval during auto scroll.
  580.   // Specified in milliseconds.
  581.   DragDropScrollInterval: integer = DD_DEFSCROLLINTERVAL; // 50
  582.  
  583.   // Default delay before dragging should start.
  584.   // Specified in milliseconds.
  585.   DragDropDragDelay: integer = DD_DEFDRAGDELAY; // 200
  586.  
  587.   // Default minimum distance (radius) before dragging should start.
  588.   // Specified in pixels.
  589.   // Not used! Instead the SM_CXDRAG and SM_CYDRAG system metrics are used.
  590.   DragDropDragMinDistance: integer = DD_DEFDRAGMINDIST; // 2
  591.  
  592.  
  593. ////////////////////////////////////////////////////////////////////////////////
  594. //
  595. //              Misc drag drop API related constants
  596. //
  597. ////////////////////////////////////////////////////////////////////////////////
  598.  
  599. // The following DVASPECT constants are missing from some versions of Delphi and
  600. // C++ Builder.
  601. {$ifndef VER135_PLUS}
  602. const
  603. {$ifndef VER10_PLUS}
  604.   DVASPECT_SHORTNAME = 2; // use for CF_HDROP to get short name version of file paths
  605. {$endif}
  606.   DVASPECT_COPY = 3; // use to indicate format is a "Copy" of the data (FILECONTENTS, FILEDESCRIPTOR, etc)
  607.   DVASPECT_LINK = 4; // use to indicate format is a "Shortcut" to the data (FILECONTENTS, FILEDESCRIPTOR, etc)
  608. {$endif}
  609.  
  610. ////////////////////////////////////////////////////////////////////////////////
  611. //
  612. //              Component registration
  613. //
  614. ////////////////////////////////////////////////////////////////////////////////
  615. procedure Register;
  616.  
  617.  
  618. (*******************************************************************************
  619. **
  620. **                      IMPLEMENTATION
  621. **
  622. *******************************************************************************)
  623. implementation
  624.  
  625. uses
  626. {$ifdef DEBUG}
  627.   ComObj,
  628. {$endif}
  629.   DropSource,
  630.   DropTarget,
  631.   DragDropFormats, // Used by TRawClipboardFormat
  632.   Messages,
  633.   ShlObj,
  634.   MMSystem,
  635.   SysUtils;
  636.  
  637. resourcestring
  638.   sImplementationRequired = 'Internal error: %s.%s needs implementation';
  639.   sInvalidOwnerType = '%s is not a valid owner for %s. Owner must be derived from %s';
  640.   sFormatNameReadOnly = '%s.ClipboardFormat is read-only';
  641.   sNoCopyStgMedium = 'A required system function (URLMON.CopyStgMedium) was not available on this system. Operation aborted.';
  642.   sBadConstructor = 'The %s class can not be instantiated with the default constructor';
  643.   sUnregisteredDataFormat = 'The %s data format has not been registered by any of the used units';
  644.  
  645.  
  646. ////////////////////////////////////////////////////////////////////////////////
  647. //
  648. //              Component registration
  649. //
  650. ////////////////////////////////////////////////////////////////////////////////
  651. procedure Register;
  652. begin
  653.   RegisterComponents(DragDropComponentPalettePage, [TDataFormatAdapter]);
  654. end;
  655.  
  656.  
  657. ////////////////////////////////////////////////////////////////////////////////
  658. //
  659. //              TInterfacedComponent
  660. //
  661. ////////////////////////////////////////////////////////////////////////////////
  662. function TInterfacedComponent.QueryInterface(const IID: TGuid; out Obj): HRESULT;
  663.  
  664. {$ifdef DEBUG}
  665.   function GuidToString(const IID: TGuid): string;
  666.   var
  667.     GUID: string;
  668.   begin
  669.     GUID := ComObj.GUIDToString(IID);
  670.     Result := GetRegStringValue('Interface\'+GUID, '');
  671.     if (Result = '') then
  672.       Result := GUID;
  673.   end;
  674. {$endif}
  675.  
  676. begin
  677. {$ifdef VER12_PLUS}
  678.   if GetInterface(IID, Obj) then
  679.     Result := 0
  680.   else if (VCLComObject <> nil) then
  681.     Result := IVCLComObject(VCLComObject).QueryInterface(IID, Obj)
  682.   else
  683.     Result := E_NOINTERFACE;
  684. {$else}
  685.   Result := inherited QueryInterface(IID, Obj);
  686. {$endif}
  687. {$ifdef DEBUG}
  688.   OutputDebugString(PChar(format('%s.QueryInterface(%s): %d (%d)',
  689.     [ClassName, GuidToString(IID), Result, ord(pointer(Obj) <> nil)])));
  690. {$endif}
  691. end;
  692.  
  693. function TInterfacedComponent._AddRef: Integer;
  694. var
  695.   Outer: IUnknown;
  696. begin
  697.   // In case we are the inner object of an aggregation, we attempt to delegate
  698.   // the reference counting to the outer object. We assume that the component
  699.   // owner is the outer object.
  700.   if (Owner <> nil) and (Owner.GetInterface(IUnknown, Outer)) then
  701.     Result := Outer._AddRef
  702.   else
  703.   begin
  704. {$ifdef VER12_PLUS}
  705.     inherited _AddRef;
  706. {$else}
  707.     if (VCLComObject <> nil) then
  708.       inherited _AddRef;
  709. {$endif}
  710.     Result := -1;
  711.   end;
  712. end;
  713.  
  714. function TInterfacedComponent._Release: Integer;
  715. var
  716.   Outer: IUnknown;
  717. begin
  718.   // See _AddRef for comments.
  719.   if (Owner <> nil) and (Owner.GetInterface(IUnknown, Outer)) then
  720.     Result := Outer._Release
  721.   else
  722.   begin
  723. {$ifdef VER12_PLUS}
  724.     inherited _Release;
  725. {$else}
  726.     if (VCLComObject <> nil) then
  727.       inherited _Release;
  728. {$endif}
  729.     Result := -1;
  730.   end;
  731. end;
  732.  
  733.  
  734. ////////////////////////////////////////////////////////////////////////////////
  735. //
  736. //              TClipboardFormat
  737. //
  738. ////////////////////////////////////////////////////////////////////////////////
  739. destructor TClipboardFormat.Destroy;
  740. begin
  741.   // Warning: Do not call Clear here. Descendant class has already
  742.   // cleaned up and released resources!
  743.   inherited Destroy;
  744. end;
  745.  
  746. constructor TClipboardFormat.CreateFormat(Atymed: Longint);
  747. begin
  748.   inherited Create;
  749.   FDataDirections := [ddRead];
  750.   FFormatEtc.cfFormat := ClipboardFormat;
  751.   FFormatEtc.ptd := nil;
  752.   FFormatEtc.dwAspect := DVASPECT_CONTENT;
  753.   FFormatEtc.lindex := -1;
  754.   FFormatEtc.tymed := Atymed;
  755. end;
  756.  
  757. constructor TClipboardFormat.CreateFormatEtc(const AFormatEtc: TFormatEtc);
  758. begin
  759.   inherited Create;
  760.   FDataDirections := [ddRead];
  761.   FFormatEtc := AFormatEtc;
  762. end;
  763.  
  764. function TClipboardFormat.HasValidFormats(ADataObject: IDataObject): boolean;
  765. begin
  766.   Result := (ADataObject.QueryGetData(FormatEtc) = S_OK);
  767. end;
  768.  
  769. function TClipboardFormat.AcceptFormat(const AFormatEtc: TFormatEtc): boolean;
  770. begin
  771.   Result := (AFormatEtc.cfFormat = FFormatEtc.cfFormat) and
  772.     (AFormatEtc.ptd = nil) and
  773.     (AFormatEtc.dwAspect = FFormatEtc.dwAspect) and
  774.     (AFormatEtc.tymed AND FFormatEtc.tymed <> 0);
  775. end;
  776.  
  777. function TClipboardFormat.Assign(Source: TCustomDataFormat): boolean;
  778. begin
  779.   Result := False;
  780. end;
  781.  
  782. function TClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean;
  783. begin
  784.   Result := False;
  785. end;
  786.  
  787. function TClipboardFormat.DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean;
  788. begin
  789.   Result := False;
  790. end;
  791.  
  792. function TClipboardFormat.DoSetData(const FormatEtcIn: TFormatEtc;
  793.   var AMedium: TStgMedium): boolean;
  794. begin
  795.   Result := False;
  796. end;
  797.  
  798. function TClipboardFormat.GetData(ADataObject: IDataObject): boolean;
  799. var
  800.   Medium                : TStgMedium;
  801. begin
  802.   Result := False;
  803.  
  804.   Clear;
  805.   if (ADataObject.GetData(FFormatEtc, Medium) <> S_OK) then
  806.     exit;
  807.   Result := GetDataFromMedium(ADataObject, Medium);
  808. end;
  809.  
  810. function TClipboardFormat.GetDataFromMedium(ADataObject: IDataObject;
  811.   var AMedium: TStgMedium): boolean;
  812. begin
  813.   Result := False;
  814.   try
  815.     Clear;
  816.     if ((AMedium.tymed AND FFormatEtc.tymed) <> 0) then
  817.       Result := DoGetData(ADataObject, AMedium);
  818.   finally
  819.     ReleaseStgMedium(AMedium);
  820.   end;
  821. end;
  822.  
  823. function TClipboardFormat.SetDataToMedium(const FormatEtcIn: TFormatEtc;
  824.   var AMedium: TStgMedium): boolean;
  825. begin
  826.   Result := False;
  827.  
  828.   FillChar(AMedium, SizeOf(AMedium), 0);
  829.  
  830.   if (FormatEtcIn.cfFormat <> FFormatEtc.cfFormat) or
  831.     (FormatEtcIn.dwAspect <> FFormatEtc.dwAspect) or
  832.     (FormatEtcIn.tymed and FFormatEtc.tymed = 0) then
  833.     exit;
  834.  
  835.   // Call descendant to allocate medium and transfer data to it
  836.   Result := DoSetData(FormatEtcIn, AMedium);
  837. end;
  838.  
  839. function TClipboardFormat.SetData(ADataObject: IDataObject;
  840.   const FormatEtcIn: TFormatEtc; var AMedium: TStgMedium): boolean;
  841. begin
  842.   // Transfer data to medium
  843.   Result := SetDataToMedium(FormatEtcIn, AMedium);
  844.  
  845.   // Call IDataObject to set data
  846.   if (Result) then
  847.     Result := (ADataObject.SetData(FormatEtc, AMedium, True) = S_OK);
  848.  
  849.   // If we didn't succeed in transfering ownership of the data medium to the
  850.   // IDataObject, we must deallocate the medium ourselves.
  851.   if (not Result) then
  852.     ReleaseStgMedium(AMedium);
  853. end;
  854.  
  855. class procedure TClipboardFormat.UnregisterClipboardFormat;
  856. begin
  857.   TDataFormatMap.Instance.DeleteByClipboardFormat(Self);
  858. end;
  859.  
  860. function TClipboardFormat.GetClipboardFormat: TClipFormat;
  861. begin
  862.   // This should have been a virtual abstract class method, but this isn't supported by C++ Builder.
  863.   raise Exception.CreateFmt(sImplementationRequired, [ClassName, 'GetClipboardFormat']);
  864. end;
  865.  
  866. procedure TClipboardFormat.SetClipboardFormat(Value: TClipFormat);
  867. begin
  868.   FFormatEtc.cfFormat := Value;
  869. end;
  870.  
  871. function TClipboardFormat.GetClipboardFormatName: string;
  872. var
  873.   Len                   : integer;
  874. begin
  875.   SetLength(Result, 255); // 255 is just an artificial limit.
  876.   Len := Windows.GetClipboardFormatName(GetClipboardFormat, PChar(Result), 255);
  877.   SetLength(Result, Len);
  878. end;
  879.  
  880. procedure TClipboardFormat.SetClipboardFormatName(const Value: string);
  881. begin
  882.   raise Exception.CreateFmt(sFormatNameReadOnly, [ClassName]);
  883. end;
  884.  
  885. function TClipboardFormat.HasData: boolean;
  886. begin
  887.   // Descendant classes are not required to override this method, so by default
  888.   // we just pretend that data is available. No harm is done by this.
  889.   Result := True;
  890. end;
  891.  
  892. procedure TClipboardFormat.SetFormatEtc(const Value: TFormatEtc);
  893. begin
  894.   FFormatEtc := Value;
  895. end;
  896.  
  897.  
  898. ////////////////////////////////////////////////////////////////////////////////
  899. //
  900. //              TClipboardFormats
  901. //
  902. ////////////////////////////////////////////////////////////////////////////////
  903. constructor TClipboardFormats.Create(ADataFormat: TCustomDataFormat;
  904.   AOwnsObjects: boolean);
  905. begin
  906.   inherited Create;
  907.   FList := TList.Create;
  908.   FDataFormat := ADataFormat;
  909.   FOwnsObjects := AOwnsObjects;
  910. end;
  911.  
  912. destructor TClipboardFormats.Destroy;
  913. begin
  914.   Clear;
  915.   FList.Free;
  916.   inherited Destroy;
  917. end;
  918.  
  919. function TClipboardFormats.Add(ClipboardFormat: TClipboardFormat): integer;
  920. begin
  921.   Result := FList.Add(ClipboardFormat);
  922.   if (FOwnsObjects) and (DataFormat <> nil) then
  923.     ClipboardFormat.DataFormat := DataFormat;
  924. end;
  925.  
  926. function TClipboardFormats.FindFormat(ClipboardFormatClass: TClipboardFormatClass): TClipboardFormat;
  927. var
  928.   i                     : integer;
  929. begin
  930.   // Search list for an object of the specified type
  931.   for i := 0 to Count-1 do
  932.     if (Formats[i].InheritsFrom(ClipboardFormatClass)) then
  933.     begin
  934.       Result := Formats[i];
  935.       exit;
  936.     end;
  937.   Result := nil;
  938. end;
  939.  
  940. function TClipboardFormats.Contain(ClipboardFormatClass: TClipboardFormatClass): boolean;
  941. begin
  942.   Result := (FindFormat(ClipboardFormatClass) <> nil);
  943. end;
  944.  
  945. function TClipboardFormats.GetCount: integer;
  946. begin
  947.   Result := FList.Count;
  948. end;
  949.  
  950. function TClipboardFormats.GetFormat(Index: integer): TClipboardFormat;
  951. begin
  952.   Result := TClipboardFormat(FList[Index]);
  953. end;
  954.  
  955. procedure TClipboardFormats.Clear;
  956. var
  957.   i                     : integer;
  958.   Format                : TObject;
  959. begin
  960.   if (FOwnsObjects) then
  961.     // Empty list and delete all objects in it
  962.     for i := Count-1 downto 0 do
  963.     begin
  964.       Format := Formats[i];
  965.       FList.Delete(i);
  966.       Format.Free;
  967.     end;
  968.  
  969.   FList.Clear;
  970. end;
  971.  
  972.  
  973. ////////////////////////////////////////////////////////////////////////////////
  974. //
  975. //              TCustomDataFormat
  976. //
  977. ////////////////////////////////////////////////////////////////////////////////
  978. constructor TCustomDataFormat.Create(AOwner: TDragDropComponent);
  979. var
  980.   ConversionScope: TConversionScope;
  981. begin
  982.   if (AOwner <> nil) then
  983.   begin
  984.     if (AOwner is TCustomDropMultiSource) then
  985.       ConversionScope := csSource
  986.     else if (AOwner is TCustomDropMultiTarget) then
  987.       ConversionScope := csTarget
  988.     else
  989.       raise Exception.CreateFmt(sInvalidOwnerType, [AOwner.ClassName, ClassName,
  990.         'TCustomDropMultiSource or TCustomDropMultiTarget']);
  991.     // Add object to owners list of data formats.
  992.     FOwner := AOwner;
  993.   end else
  994.     // TODO : This sucks! All this ConversionScope stuff should be redesigned.
  995.     ConversionScope := csTarget;
  996.  
  997.   FCompatibleFormats := TClipboardFormats.Create(Self, True);
  998.   // Populate list with all the clipboard formats that have been registered as
  999.   // compatible with this data format.
  1000.   TDataFormatMap.Instance.GetSourceByDataFormat(TDataFormatClass(ClassType),
  1001.     FCompatibleFormats, ConversionScope);
  1002.  
  1003.   if (FOwner <> nil) then
  1004.     FOwner.DataFormats.Add(Self);
  1005. end;
  1006.  
  1007. destructor TCustomDataFormat.Destroy;
  1008. begin
  1009.   FCompatibleFormats.Free;
  1010.   // Remove object from owners list of target formats
  1011.   if (FOwner <> nil) then
  1012.     FOwner.DataFormats.Remove(Self);
  1013.   inherited Destroy;
  1014. end;
  1015.  
  1016. function TCustomDataFormat.Assign(Source: TClipboardFormat): boolean;
  1017. begin
  1018.   // Called when derived class(es) couldn't convert from the source format.
  1019.   // Try to let source format convert to this format instead.
  1020.   Result := Source.AssignTo(Self);
  1021. end;
  1022.  
  1023. function TCustomDataFormat.AssignTo(Dest: TClipboardFormat): boolean;
  1024. begin
  1025.   // Called when derived class(es) couldn't convert to the destination format.
  1026.   // Try to let destination format convert from this format instead.
  1027.   Result := Dest.Assign(Self);
  1028. end;
  1029.  
  1030. function TCustomDataFormat.GetData(DataObject: IDataObject): boolean;
  1031. var
  1032.   i: integer;
  1033. begin
  1034.   Result := False;
  1035.   i := 0;
  1036.   // Get data from each of our associated clipboard formats until we don't
  1037.   // need anymore data.
  1038.   while (NeedsData) and (i < CompatibleFormats.Count) do
  1039.   begin
  1040.     CompatibleFormats[i].Clear;
  1041.  
  1042.     if (CompatibleFormats[i].GetData(DataObject)) and
  1043.       (CompatibleFormats[i].HasData) then
  1044.     begin
  1045.       if (Assign(CompatibleFormats[i])) then
  1046.       begin
  1047.         // Once data has been sucessfully transfered to the TDataFormat object,
  1048.         // we clear the data in the TClipboardFormat object in order to conserve
  1049.         // resources.
  1050.         CompatibleFormats[i].Clear;
  1051.         Result := True;
  1052.       end;
  1053.     end;
  1054.  
  1055.     inc(i);
  1056.   end;
  1057. end;
  1058.  
  1059. function TCustomDataFormat.NeedsData: boolean;
  1060. begin
  1061.   Result := not HasData;
  1062. end;
  1063.  
  1064. function TCustomDataFormat.HasValidFormats(ADataObject: IDataObject): boolean;
  1065. var
  1066.   i: integer;
  1067. begin
  1068.   // Determine if any of the registered clipboard formats can read from the
  1069.   // specified data object.
  1070.   Result := False;
  1071.   for i := 0 to CompatibleFormats.Count-1 do
  1072.     if (CompatibleFormats[i].HasValidFormats(ADataObject)) then
  1073.     begin
  1074.       Result := True;
  1075.       break;
  1076.     end;
  1077. end;
  1078.  
  1079. function TCustomDataFormat.AcceptFormat(const FormatEtc: TFormatEtc): boolean;
  1080. var
  1081.   i: integer;
  1082. begin
  1083.   // Determine if any of the registered clipboard formats can handle the
  1084.   // specified clipboard format.
  1085.   Result := False;
  1086.   for i := 0 to CompatibleFormats.Count-1 do
  1087.     if (CompatibleFormats[i].AcceptFormat(FormatEtc)) then
  1088.     begin
  1089.       Result := True;
  1090.       break;
  1091.     end;
  1092. end;
  1093.  
  1094. class procedure TCustomDataFormat.RegisterDataFormat;
  1095. begin
  1096.   TDataFormatClasses.Instance.Add(Self);
  1097. end;
  1098.  
  1099. class procedure TCustomDataFormat.RegisterCompatibleFormat(ClipboardFormatClass: TClipboardFormatClass;
  1100.   Priority: integer; ConversionScopes: TConversionScopes;
  1101.   DataDirections: TDataDirections);
  1102. begin
  1103.   // Register format mapping.
  1104.   TDataFormatMap.Instance.RegisterFormatMap(Self, ClipboardFormatClass,
  1105.     Priority, ConversionScopes, DataDirections);
  1106. end;
  1107.  
  1108. function TCustomDataFormat.SupportsFormat(ClipboardFormat: TClipboardFormat): boolean;
  1109. begin
  1110.   Result := CompatibleFormats.Contain(TClipboardFormatClass(ClipboardFormat.ClassType));
  1111. end;
  1112.  
  1113. class procedure TCustomDataFormat.UnregisterCompatibleFormat(ClipboardFormatClass: TClipboardFormatClass);
  1114. begin
  1115.   // Unregister format mapping
  1116.   TDataFormatMap.Instance.UnregisterFormatMap(Self, ClipboardFormatClass);
  1117. end;
  1118.  
  1119. class procedure TCustomDataFormat.UnregisterDataFormat;
  1120. begin
  1121.   TDataFormatMap.Instance.DeleteByDataFormat(Self);
  1122.   TDataFormatClasses.Instance.Remove(Self);
  1123. end;
  1124.  
  1125. procedure TCustomDataFormat.DoOnChanging(Sender: TObject);
  1126. begin
  1127.   Changing;
  1128. end;
  1129.  
  1130. procedure TCustomDataFormat.Changing;
  1131. begin
  1132.   if (Assigned(OnChanging)) then
  1133.     OnChanging(Self);
  1134. end;
  1135.  
  1136.  
  1137. ////////////////////////////////////////////////////////////////////////////////
  1138. //
  1139. //              TDataFormats
  1140. //
  1141. ////////////////////////////////////////////////////////////////////////////////
  1142. function TDataFormats.Add(DataFormat: TCustomDataFormat): integer;
  1143. begin
  1144.   Result := FList.IndexOf(DataFormat);
  1145.   if (Result = -1) then
  1146.     Result := FList.Add(DataFormat);
  1147. end;
  1148.  
  1149. constructor TDataFormats.Create;
  1150. begin
  1151.   inherited Create;
  1152.   FList := TList.Create;
  1153. end;
  1154.  
  1155. destructor TDataFormats.Destroy;
  1156. var
  1157.   i: integer;
  1158. begin
  1159.   for i := FList.Count-1 downto 0 do
  1160.     Remove(TCustomDataFormat(FList[i]));
  1161.   FList.Free;
  1162.   inherited Destroy;
  1163. end;
  1164.  
  1165. function TDataFormats.GetCount: integer;
  1166. begin
  1167.   Result := FList.Count;
  1168. end;
  1169.  
  1170. function TDataFormats.GetFormat(Index: integer): TCustomDataFormat;
  1171. begin
  1172.   Result := TCustomDataFormat(FList[Index]);
  1173. end;
  1174.  
  1175. function TDataFormats.IndexOf(DataFormat: TCustomDataFormat): integer;
  1176. begin
  1177.   Result := FList.IndexOf(DataFormat);
  1178. end;
  1179.  
  1180. procedure TDataFormats.Remove(DataFormat: TCustomDataFormat);
  1181. begin
  1182.   FList.Remove(DataFormat);
  1183. end;
  1184.  
  1185. ////////////////////////////////////////////////////////////////////////////////
  1186. //
  1187. //              TDataFormatClasses
  1188. //
  1189. ////////////////////////////////////////////////////////////////////////////////
  1190. function TDataFormatClasses.Add(DataFormat: TDataFormatClass): integer;
  1191. begin
  1192.   Result := FList.IndexOf(DataFormat);
  1193.   if (Result = -1) then
  1194.     Result := FList.Add(DataFormat);
  1195. end;
  1196.  
  1197. constructor TDataFormatClasses.Create;
  1198. begin
  1199.   inherited Create;
  1200.   FList := TList.Create;
  1201. end;
  1202.  
  1203. destructor TDataFormatClasses.Destroy;
  1204. var
  1205.   i: integer;
  1206. begin
  1207.   for i := FList.Count-1 downto 0 do
  1208.     Remove(TDataFormatClass(FList[i]));
  1209.   FList.Free;
  1210.   inherited Destroy;
  1211. end;
  1212.  
  1213. function TDataFormatClasses.GetCount: integer;
  1214. begin
  1215.   Result := FList.Count;
  1216. end;
  1217.  
  1218. function TDataFormatClasses.GetFormat(Index: integer): TDataFormatClass;
  1219. begin
  1220.   Result := TDataFormatClass(FList[Index]);
  1221. end;
  1222.  
  1223. var
  1224.   FDataFormatClasses: TDataFormatClasses = nil;
  1225.  
  1226. class function TDataFormatClasses.Instance: TDataFormatClasses;
  1227. begin
  1228.   if (FDataFormatClasses = nil) then
  1229.     FDataFormatClasses := TDataFormatClasses.Create;
  1230.   Result := FDataFormatClasses;
  1231. end;
  1232.  
  1233. procedure TDataFormatClasses.Remove(DataFormat: TDataFormatClass);
  1234. begin
  1235.   FList.Remove(DataFormat);
  1236. end;
  1237.  
  1238.  
  1239. ////////////////////////////////////////////////////////////////////////////////
  1240. //
  1241. //              TDataFormatMap
  1242. //
  1243. ////////////////////////////////////////////////////////////////////////////////
  1244. type
  1245.   // TTargetFormat / TClipboardFormat association
  1246.   TFormatMap = record
  1247.     DataFormat: TDataFormatClass;
  1248.     ClipboardFormat: TClipboardFormatClass;
  1249.     Priority: integer;
  1250.     ConversionScopes: TConversionScopes;
  1251.     DataDirections: TDataDirections;
  1252.   end;
  1253.  
  1254.   PFormatMap = ^TFormatMap;
  1255.  
  1256. constructor TDataFormatMap.Create;
  1257. begin
  1258.   inherited Create;
  1259.   FList := TList.Create;
  1260. end;
  1261.  
  1262. destructor TDataFormatMap.Destroy;
  1263. var
  1264.   i                     : integer;
  1265. begin
  1266.   // Zap any mapings which hasn't been unregistered
  1267.   // yet (actually an error condition)
  1268.   for i := FList.Count-1 downto 0 do
  1269.     Dispose(FList[i]);
  1270.   FList.Free;
  1271.   inherited Destroy;
  1272. end;
  1273.  
  1274. procedure TDataFormatMap.Sort;
  1275. var
  1276.   i                     : integer;
  1277.   NewMap                : PFormatMap;
  1278. begin
  1279.   // Note: We do not use the built-in Sort method of TList because
  1280.   // we need to preserve the order in which the mappings were added.
  1281.   // New mappings have higher precedence than old mappings (within the
  1282.   // same priority).
  1283.  
  1284.   // Preconditions:
  1285.   // 1) The list is already sorted before a new mapping is added.
  1286.   // 2) The new mapping is always added to the end of the list.
  1287.  
  1288.   NewMap := PFormatMap(FList.Last);
  1289.  
  1290.   // Scan the list for a map with the same TTargetFormat type
  1291.   i := FList.Count-2;
  1292.   while (i > 0) do
  1293.   begin
  1294.     if (PFormatMap(FList[i])^.DataFormat = NewMap^.DataFormat) then
  1295.     begin
  1296.       // Scan the list for a map with lower priority
  1297.       repeat
  1298.         if (PFormatMap(FList[i])^.Priority < NewMap^.Priority) then
  1299.         begin
  1300.           // Move the mapping to the new position
  1301.           FList.Move(FList.Count-1, i+1);
  1302.           exit;
  1303.         end;
  1304.         dec(i);
  1305.       until (i < 0) or (PFormatMap(FList[i])^.DataFormat <> NewMap^.DataFormat);
  1306.       // Move the mapping to the new position
  1307.       FList.Move(FList.Count-1, i+1);
  1308.       exit;
  1309.     end;
  1310.     dec(i);
  1311.   end;
  1312. end;
  1313.  
  1314. procedure TDataFormatMap.Add(DataFormatClass: TDataFormatClass;
  1315.   ClipboardFormatClass: TClipboardFormatClass; Priority: integer;
  1316.   ConversionScopes: TConversionScopes; DataDirections: TDataDirections);
  1317. var
  1318.   FormatMap             : PFormatMap;
  1319.   OldMap                : integer;
  1320. begin
  1321.   // Avoid duplicate mappings
  1322.   OldMap := FindMap(DataFormatClass, ClipboardFormatClass);
  1323.   if (OldMap = -1) then
  1324.   begin
  1325.     // Add new mapping...
  1326.     New(FormatMap);
  1327.     FList.Add(FormatMap);
  1328.     FormatMap^.ConversionScopes := ConversionScopes;
  1329.     FormatMap^.DataDirections := DataDirections;
  1330.   end else
  1331.   begin
  1332.     // Replace old mapping...
  1333.     FormatMap := FList[OldMap];
  1334.     FList.Move(OldMap, FList.Count-1);
  1335.     FormatMap^.ConversionScopes := FormatMap^.ConversionScopes + ConversionScopes;
  1336.     FormatMap^.DataDirections := FormatMap^.DataDirections + DataDirections;
  1337.   end;
  1338.  
  1339.   FormatMap^.ClipboardFormat := ClipboardFormatClass;
  1340.   FormatMap^.DataFormat := DataFormatClass;
  1341.   FormatMap^.Priority := Priority;
  1342.   // ...and sort list
  1343.   Sort;
  1344. end;
  1345.  
  1346. function TDataFormatMap.CanMap(DataFormatClass: TDataFormatClass;
  1347.   ClipboardFormatClass: TClipboardFormatClass): boolean;
  1348. begin
  1349.   Result := (FindMap(DataFormatClass, ClipboardFormatClass) <> -1);
  1350. end;
  1351.  
  1352. procedure TDataFormatMap.Delete(DataFormatClass: TDataFormatClass;
  1353.   ClipboardFormatClass: TClipboardFormatClass);
  1354. var
  1355.   Index                 : integer;
  1356. begin
  1357.   Index := FindMap(DataFormatClass, ClipboardFormatClass);
  1358.   if (Index <> -1) then
  1359.   begin
  1360.     Dispose(FList[Index]);
  1361.     FList.Delete(Index);
  1362.   end;
  1363. end;
  1364.  
  1365. procedure TDataFormatMap.DeleteByClipboardFormat(ClipboardFormatClass: TClipboardFormatClass);
  1366. var
  1367.   i                     : integer;
  1368. begin
  1369.   // Delete all mappings associated with the specified clipboard format
  1370.   for i := FList.Count-1 downto 0 do
  1371.     if (PFormatMap(FList[i])^.ClipboardFormat.InheritsFrom(ClipboardFormatClass)) then
  1372.     begin
  1373.       Dispose(FList[i]);
  1374.       FList.Delete(i);
  1375.     end;
  1376. end;
  1377.  
  1378. procedure TDataFormatMap.DeleteByDataFormat(DataFormatClass: TDataFormatClass);
  1379. var
  1380.   i                     : integer;
  1381. begin
  1382.   // Delete all mappings associated with the specified target format
  1383.   for i := FList.Count-1 downto 0 do
  1384.     if (PFormatMap(FList[i])^.DataFormat.InheritsFrom(DataFormatClass)) then
  1385.     begin
  1386.       Dispose(FList[i]);
  1387.       FList.Delete(i);
  1388.     end;
  1389. end;
  1390.  
  1391. function TDataFormatMap.FindMap(DataFormatClass: TDataFormatClass;
  1392.   ClipboardFormatClass: TClipboardFormatClass): integer;
  1393. var
  1394.   i                     : integer;
  1395. begin
  1396.   for i := 0 to FList.Count-1 do
  1397.     if (PFormatMap(FList[i])^.DataFormat.InheritsFrom(DataFormatClass)) and
  1398.       (PFormatMap(FList[i])^.ClipboardFormat.InheritsFrom(ClipboardFormatClass)) then
  1399.     begin
  1400.       Result := i;
  1401.       exit;
  1402.     end;
  1403.   Result := -1;
  1404. end;
  1405.  
  1406. procedure TDataFormatMap.GetSourceByDataFormat(DataFormatClass: TDataFormatClass;
  1407.   ClipboardFormats: TClipboardFormats; ConversionScope: TConversionScope);
  1408. var
  1409.   i: integer;
  1410.   ClipboardFormat: TClipboardFormat;
  1411. begin
  1412.   // Clear the list...
  1413.   ClipboardFormats.Clear;
  1414.   // ...and populate it with *instances* of all the clipbard
  1415.   // formats associated with the specified target format and
  1416.   // registered with the specified data direction.
  1417.   for i := 0 to FList.Count-1 do
  1418.     if (ConversionScope in PFormatMap(FList[i])^.ConversionScopes) and
  1419.       (PFormatMap(FList[i])^.DataFormat.InheritsFrom(DataFormatClass)) then
  1420.     begin
  1421.       ClipboardFormat := PFormatMap(FList[i])^.ClipboardFormat.Create;
  1422.       ClipboardFormat.DataDirections := PFormatMap(FList[i])^.DataDirections;
  1423.       ClipboardFormats.Add(ClipboardFormat);
  1424.     end;
  1425. end;
  1426.  
  1427. procedure TDataFormatMap.RegisterFormatMap(DataFormatClass: TDataFormatClass;
  1428.   ClipboardFormatClass: TClipboardFormatClass; Priority: integer;
  1429.   ConversionScopes: TConversionScopes; DataDirections: TDataDirections);
  1430. begin
  1431.   Add(DataFormatClass, ClipboardFormatClass, Priority, ConversionScopes,
  1432.     DataDirections);
  1433. end;
  1434.  
  1435. procedure TDataFormatMap.UnregisterFormatMap(DataFormatClass: TDataFormatClass;
  1436.   ClipboardFormatClass: TClipboardFormatClass);
  1437. begin
  1438.   Delete(DataFormatClass, ClipboardFormatClass);
  1439. end;
  1440.  
  1441. var
  1442.   FDataFormatMap: TDataFormatMap = nil;
  1443.  
  1444. class function TDataFormatMap.Instance: TDataFormatMap;
  1445. begin
  1446.   if (FDataFormatMap = nil) then
  1447.     FDataFormatMap := TDataFormatMap.Create;
  1448.   Result := FDataFormatMap;
  1449. end;
  1450.  
  1451. ////////////////////////////////////////////////////////////////////////////////
  1452. //
  1453. //              TDataFormatAdapter
  1454. //
  1455. ////////////////////////////////////////////////////////////////////////////////
  1456. destructor TDataFormatAdapter.Destroy;
  1457. begin
  1458.   inherited Destroy;
  1459. end;
  1460.  
  1461. function TDataFormatAdapter.GetDataFormatName: string;
  1462. begin
  1463.   if Assigned(FDataFormatClass) then
  1464.     Result := FDataFormatClass.ClassName
  1465.   else
  1466.     Result := '';
  1467. end;
  1468.  
  1469. function TDataFormatAdapter.GetEnabled: boolean;
  1470. begin
  1471.   if (csDesigning in ComponentState) then
  1472.     Result := FEnabled
  1473.   else
  1474.     Result := Assigned(FDataFormat) and Assigned(FDataFormatClass);
  1475. end;
  1476.  
  1477. procedure TDataFormatAdapter.Loaded;
  1478. begin
  1479.   inherited;
  1480.   if (FEnabled) then
  1481.     Enabled := True;
  1482. end;
  1483.  
  1484. procedure TDataFormatAdapter.Notification(AComponent: TComponent;
  1485.   Operation: TOperation);
  1486. begin
  1487.   if (Operation = opRemove) and (AComponent = FDragDropComponent) then
  1488.     DragDropComponent := nil;
  1489.   inherited;
  1490. end;
  1491.  
  1492. procedure TDataFormatAdapter.SetDataFormatClass(const Value: TDataFormatClass);
  1493. begin
  1494.   if (Value <> FDataFormatClass) then
  1495.   begin
  1496.     if not(csLoading in ComponentState) then
  1497.       Enabled := False;
  1498.     FDataFormatClass := Value;
  1499.   end;
  1500. end;
  1501.  
  1502. procedure TDataFormatAdapter.SetDataFormatName(const Value: string);
  1503. var
  1504.   i: integer;
  1505.   ADataFormatClass: TDataFormatClass;
  1506. begin
  1507.   ADataFormatClass := nil;
  1508.   if (Value <> '') then
  1509.   begin
  1510.     for i := 0 to TDataFormatClasses.Instance.Count-1 do
  1511.       if (AnsiCompareText(TDataFormatClasses.Instance[i].ClassName, Value) = 0) then
  1512.       begin
  1513.         ADataFormatClass := TDataFormatClasses.Instance[i];
  1514.         break;
  1515.       end;
  1516.     if (ADataFormatClass = nil) then
  1517.       raise Exception.CreateFmt(sUnregisteredDataFormat, [Value]);
  1518.   end;
  1519.   DataFormatClass := ADataFormatClass;
  1520. end;
  1521.  
  1522. procedure TDataFormatAdapter.SetDragDropComponent(const Value: TDragDropComponent);
  1523. begin
  1524.   if (Value <> FDragDropComponent) then
  1525.   begin
  1526.     if not(csLoading in ComponentState) then
  1527.       Enabled := False;
  1528.     if (FDragDropComponent <> nil) then
  1529.       FDragDropComponent.RemoveFreeNotification(Self);
  1530.     FDragDropComponent := Value;
  1531.     if (Value <> nil) then
  1532.       Value.FreeNotification(Self);
  1533.   end;
  1534. end;
  1535.  
  1536. procedure TDataFormatAdapter.SetEnabled(const Value: boolean);
  1537. begin
  1538.   if (csLoading in ComponentState) then
  1539.   begin
  1540.     FEnabled := Value;
  1541.   end else
  1542.   if (csDesigning in ComponentState) then
  1543.   begin
  1544.     FEnabled := Value and Assigned(FDragDropComponent) and
  1545.       Assigned(FDataFormatClass);
  1546.   end else
  1547.   if (Value) then
  1548.   begin
  1549.     if (Assigned(FDragDropComponent)) and (Assigned(FDataFormatClass)) and
  1550.       (not Assigned(FDataFormat)) then
  1551.       FDataFormat := FDataFormatClass.Create(FDragDropComponent);
  1552.   end else
  1553.   begin
  1554.     if Assigned(FDataFormat) then
  1555.     begin
  1556.       if Assigned(FDragDropComponent) and
  1557.         (FDragDropComponent.DataFormats.IndexOf(FDataFormat) <> -1) then
  1558.         FDataFormat.Free;
  1559.       FDataFormat := nil;
  1560.     end;
  1561.   end;
  1562. end;
  1563.  
  1564.  
  1565. ////////////////////////////////////////////////////////////////////////////////
  1566. //
  1567. //              TRawClipboardFormat
  1568. //
  1569. ////////////////////////////////////////////////////////////////////////////////
  1570. constructor TRawClipboardFormat.Create;
  1571. begin
  1572.   // Yeah, it's a hack but blame Borland for making TObject.Create public!
  1573.   raise Exception.CreateFmt(sBadConstructor, [ClassName]);
  1574. end;
  1575.  
  1576. constructor TRawClipboardFormat.CreateFormatEtc(const AFormatEtc: TFormatEtc);
  1577. begin
  1578.   inherited CreateFormatEtc(AFormatEtc);
  1579. end;
  1580.  
  1581. procedure TRawClipboardFormat.SetClipboardFormatName(const Value: string);
  1582. begin
  1583.   ClipboardFormat := RegisterClipboardFormat(PChar(Value));
  1584. end;
  1585.  
  1586. function TRawClipboardFormat.GetClipboardFormat: TClipFormat;
  1587. begin
  1588.   Result := FFormatEtc.cfFormat;
  1589. end;
  1590.  
  1591. function TRawClipboardFormat.Assign(Source: TCustomDataFormat): boolean;
  1592. begin
  1593.   if (Source is TRawDataFormat) then
  1594.   begin
  1595.     Result := True;
  1596.   end else
  1597.     Result := inherited Assign(Source);
  1598. end;
  1599.  
  1600. function TRawClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean;
  1601. begin
  1602.   if (Dest is TRawDataFormat) then
  1603.   begin
  1604.     Result := True;
  1605.   end else
  1606.     Result := inherited AssignTo(Dest);
  1607. end;
  1608.  
  1609. procedure TRawClipboardFormat.Clear;
  1610. begin
  1611.   // Since TRawDataFormat performs storage for TRawDataFormat we only allow
  1612.   // TRawDataFormat to clear. To accomplish this TRawDataFormat ignores calls to
  1613.   // the clear method and instead introduces the ClearData method.
  1614. end;
  1615.  
  1616. procedure TRawClipboardFormat.ClearData;
  1617. begin
  1618.   ReleaseStgMedium(FMedium);
  1619.   FillChar(FMedium, SizeOf(FMedium), 0);
  1620. end;
  1621.  
  1622. function TRawClipboardFormat.HasData: boolean;
  1623. begin
  1624.   Result := (FMedium.tymed <> TYMED_NULL);
  1625. end;
  1626.  
  1627. function TRawClipboardFormat.NeedsData: boolean;
  1628. begin
  1629.   Result := (FMedium.tymed = TYMED_NULL);
  1630. end;
  1631.  
  1632. procedure TRawClipboardFormat.CopyFromStgMedium(const AMedium: TStgMedium);
  1633. begin
  1634.   CopyStgMedium(AMedium, FMedium);
  1635. end;
  1636.  
  1637. procedure TRawClipboardFormat.CopyToStgMedium(var AMedium: TStgMedium);
  1638. begin
  1639.   CopyStgMedium(FMedium, AMedium);
  1640. end;
  1641.  
  1642. function TRawClipboardFormat.DoGetData(ADataObject: IDataObject;
  1643.   const AMedium: TStgMedium): boolean;
  1644. begin
  1645.   Result := CopyStgMedium(AMedium, FMedium);
  1646. end;
  1647.  
  1648. function TRawClipboardFormat.DoSetData(const FormatEtcIn: TFormatEtc;
  1649.   var AMedium: TStgMedium): boolean;
  1650. begin
  1651.   Result := CopyStgMedium(FMedium, AMedium);
  1652. end;
  1653.  
  1654. function TRawClipboardFormat.GetString: string;
  1655. begin
  1656.   with TTextClipboardFormat.Create do
  1657.     try
  1658.       if GetDataFromMedium(nil, FMedium) then
  1659.         Result := Text
  1660.       else
  1661.         Result := '';
  1662.     finally
  1663.       Free;
  1664.     end;
  1665. end;
  1666.  
  1667. procedure TRawClipboardFormat.SetString(const Value: string);
  1668. begin
  1669.   with TTextClipboardFormat.Create do
  1670.     try
  1671.       Text := Value;
  1672.       SetDataToMedium(FormatEtc, FMedium);
  1673.     finally
  1674.       Free;
  1675.     end;
  1676. end;
  1677.  
  1678. ////////////////////////////////////////////////////////////////////////////////
  1679. //
  1680. //              TRawDataFormat
  1681. //
  1682. ////////////////////////////////////////////////////////////////////////////////
  1683. procedure TRawDataFormat.Clear;
  1684. var
  1685.  i: integer;
  1686. begin
  1687.   Changing;
  1688.   for i := 0 to CompatibleFormats.Count-1 do
  1689.     TRawClipboardFormat(CompatibleFormats[i]).ClearData;
  1690. end;
  1691.  
  1692. function TRawDataFormat.HasData: boolean;
  1693. var
  1694.  i: integer;
  1695. begin
  1696.   i := 0;
  1697.   Result := False;
  1698.   while (not Result) and (i < CompatibleFormats.Count) do
  1699.   begin
  1700.     Result := TRawClipboardFormat(CompatibleFormats[i]).HasData;
  1701.     inc(i);
  1702.   end;
  1703. end;
  1704.  
  1705. function TRawDataFormat.NeedsData: boolean;
  1706. var
  1707.  i: integer;
  1708. begin
  1709.   i := 0;
  1710.   Result := False;
  1711.   while (not Result) and (i < CompatibleFormats.Count) do
  1712.   begin
  1713.     Result := TRawClipboardFormat(CompatibleFormats[i]).NeedsData;
  1714.     inc(i);
  1715.   end;
  1716. end;
  1717.  
  1718.  
  1719. ////////////////////////////////////////////////////////////////////////////////
  1720. //
  1721. //              Utility functions
  1722. //
  1723. ////////////////////////////////////////////////////////////////////////////////
  1724. procedure _RaiseLastWin32Error;
  1725. begin
  1726. {$ifdef VER14_PLUS}
  1727.   RaiseLastOSError;
  1728. {$else}
  1729.   RaiseLastWin32Error;
  1730. {$endif}
  1731. end;
  1732.  
  1733. function DropEffectToDragType(DropEffect: longInt; var DragType: TDragType): boolean;
  1734. begin
  1735.   Result := True;
  1736.   if ((DropEffect and DROPEFFECT_COPY) <> 0) then
  1737.     DragType := dtCopy
  1738.   else
  1739.     if ((DropEffect and DROPEFFECT_MOVE) <> 0) then
  1740.       DragType := dtMove
  1741.     else
  1742.       if ((DropEffect and DROPEFFECT_LINK) <> 0) then
  1743.         DragType := dtLink
  1744.       else
  1745.       begin
  1746.         DragType := dtCopy;
  1747.         Result := False;
  1748.       end;
  1749. end;
  1750.  
  1751. function DragTypesToDropEffect(DragTypes: TDragTypes): longint;
  1752. begin
  1753.   Result := DROPEFFECT_NONE;
  1754.   if (dtCopy in DragTypes) then
  1755.     Result := Result OR DROPEFFECT_COPY;
  1756.   if (dtMove in DragTypes) then
  1757.     Result := Result OR DROPEFFECT_MOVE;
  1758.   if (dtLink in DragTypes) then
  1759.     Result := Result OR DROPEFFECT_LINK;
  1760. end;
  1761.  
  1762. // Replacement for the buggy DragDetect API function.
  1763. function DragDetectPlus(Handle: THandle; p: TPoint): boolean;
  1764. var
  1765.   DragRect: TRect;
  1766.   Msg: TMsg;
  1767.   StartTime: DWORD;
  1768.   OldCapture: HWND;
  1769. begin
  1770.   Result := False;
  1771.   if (not ClientToScreen(Handle, p)) then
  1772.     exit;
  1773.   // Calculate the drag rect. If the mouse leaves this rect while the
  1774.   // mouse button is pressed, a drag is detected.
  1775.   DragRect.TopLeft := p;
  1776.   DragRect.BottomRight := p;
  1777.   InflateRect(DragRect, GetSystemMetrics(SM_CXDRAG), GetSystemMetrics(SM_CYDRAG));
  1778.   StartTime := TimeGetTime;
  1779.   // Capture the mouse so that we will receive mouse messages even after the
  1780.   // mouse leaves the control rect.
  1781.   OldCapture := SetCapture(Handle);
  1782.   try
  1783.     // Abort if we failed to capture the mouse.
  1784.     if (GetCapture <> Handle) then
  1785.       exit;
  1786.     while (not Result) do
  1787.     begin
  1788.       // Detect if all mouse buttons are up (might mean that we missed a
  1789.       // MW_?BUTTONUP message).
  1790.       if (GetAsyncKeyState(VK_LBUTTON) AND $8000 = 0) and
  1791.         (GetAsyncKeyState(VK_RBUTTON) AND $8000 = 0) then
  1792.         break;
  1793.  
  1794.       if (PeekMessage(Msg, Handle, 0,0, PM_REMOVE)) then
  1795.       begin
  1796.         case (Msg.message) of
  1797.           WM_MOUSEMOVE:
  1798.             // Mouse were moved. Check if we are still within the drag rect...
  1799.             Result := (not PtInRect(DragRect, Msg.pt)) and
  1800.               // ... and that the minimum time has elapsed.
  1801.               // Note that we ignore time warp (wrap around) and that Msg.Time
  1802.               // might be smaller than StartTime.
  1803.               (Msg.time >= StartTime + DWORD(DragDropDragDelay));
  1804.           WM_RBUTTONUP,
  1805.           WM_LBUTTONUP,
  1806.           WM_CANCELMODE:
  1807.             // Mouse button were released, escape were pressed or some other
  1808.             // operation cancelled our mouse capture.
  1809.             break;
  1810.           WM_QUIT:
  1811.             // Application is shutting down. Get out of here fast.
  1812.             exit;
  1813.         else
  1814.           TranslateMessage(Msg);
  1815.           DispatchMessage(Msg);
  1816.         end;
  1817.       end else
  1818.         Sleep(0);
  1819.     end;
  1820.   finally
  1821.     ReleaseCapture;
  1822.     // Restore previous capture.
  1823.     if (OldCapture <> 0) then
  1824.       SetCapture(OldCapture);
  1825.   end;
  1826. end;
  1827.  
  1828. function ClientPtToWindowPt(Handle: THandle; pt: TPoint): TPoint;
  1829. var
  1830.   Rect: TRect;
  1831. begin
  1832.   ClientToScreen(Handle, pt);
  1833.   GetWindowRect(Handle, Rect);
  1834.   Result.X := pt.X - Rect.Left;
  1835.   Result.Y := pt.Y - Rect.Top;
  1836. end;
  1837.  
  1838. const
  1839.   // Note: The definition of MK_ALT is missing from the current Delphi (D5)
  1840.   // declarations. Hopefully Delphi 6 will fix this.
  1841.   MK_ALT = $20;
  1842.  
  1843. function KeysToShiftStatePlus(Keys: Word): TShiftState;
  1844. begin
  1845.   Result := [];
  1846.   if (Keys and MK_SHIFT <> 0) then
  1847.     Include(Result, ssShift);
  1848.   if (Keys and MK_CONTROL <> 0) then
  1849.     Include(Result, ssCtrl);
  1850.   if (Keys and MK_LBUTTON <> 0) then
  1851.     Include(Result, ssLeft);
  1852.   if (Keys and MK_RBUTTON <> 0) then
  1853.     Include(Result, ssRight);
  1854.   if (Keys and MK_MBUTTON <> 0) then
  1855.     Include(Result, ssMiddle);
  1856.   if (Keys and MK_ALT <> 0) then
  1857.     Include(Result, ssMiddle);
  1858. end;
  1859.  
  1860. function ShiftStateToDropEffect(Shift: TShiftState; AllowedEffects: longint;
  1861.   Fallback: boolean): longint;
  1862. begin
  1863.   // As we're only interested in ssShift & ssCtrl here,
  1864.   // mouse button states are screened out.
  1865.   Shift := Shift * [ssShift, ssCtrl];
  1866.  
  1867.   Result := DROPEFFECT_NONE;
  1868.   if (Shift = [ssShift, ssCtrl]) then
  1869.   begin
  1870.     if (AllowedEffects AND DROPEFFECT_LINK <> 0) then
  1871.       Result := DROPEFFECT_LINK;
  1872.   end else
  1873.   if (Shift = [ssCtrl]) then
  1874.   begin
  1875.     if (AllowedEffects AND DROPEFFECT_COPY <> 0) then
  1876.       Result := DROPEFFECT_COPY;
  1877.   end else
  1878.   begin
  1879.     if (AllowedEffects AND DROPEFFECT_MOVE <> 0) then
  1880.       Result := DROPEFFECT_MOVE;
  1881.   end;
  1882.  
  1883.   // Fall back to defaults if the shift-states specified an
  1884.   // unavailable drop effect.
  1885.   if (Result = DROPEFFECT_NONE) and (Fallback) then
  1886.   begin
  1887.     if (AllowedEffects AND DROPEFFECT_COPY <> 0) then
  1888.       Result := DROPEFFECT_COPY
  1889.     else if (AllowedEffects AND DROPEFFECT_MOVE <> 0) then
  1890.       Result := DROPEFFECT_MOVE
  1891.     else if (AllowedEffects AND DROPEFFECT_LINK <> 0) then
  1892.       Result := DROPEFFECT_LINK;
  1893.   end;
  1894. end;
  1895.  
  1896. var
  1897.   URLMONDLL: THandle = 0;
  1898.   _CopyStgMedium: function(const cstgmedSrc: TStgMedium; var stgmedDest: TStgMedium): HResult; stdcall = nil;
  1899.  
  1900. function CopyStgMedium(const SrcMedium: TStgMedium; var DstMedium: TStgMedium): boolean;
  1901. begin
  1902.   // Copy the medium via the URLMON CopyStgMedium function. This should be safe
  1903.   // since this function is only called when the drag drop helper object is
  1904.   // used and the drag drop helper object is only supported on Windows 2000
  1905.   // and later.
  1906.   // URLMON.CopyStgMedium requires IE4 or later.
  1907.   // An alternative approach would be to use OleDuplicateData, but based on a
  1908.   // disassembly of urlmon.dll, CopyStgMedium seems to do a lot more than
  1909.   // OleDuplicateData.
  1910.   if (URLMONDLL = 0) then
  1911.   begin
  1912.     URLMONDLL := LoadLibrary('URLMON.DLL');
  1913.     if (URLMONDLL <> 0) then
  1914.       @_CopyStgMedium := GetProcAddress(URLMONDLL, 'CopyStgMedium');
  1915.   end;
  1916.  
  1917.   if (@_CopyStgMedium = nil) then
  1918.     raise Exception.Create(sNoCopyStgMedium);
  1919.  
  1920.   Result := (_CopyStgMedium(SrcMedium, DstMedium) = S_OK);
  1921. end;
  1922.  
  1923. function GetClipboardFormatNameStr(Value: TClipFormat): string;
  1924. var
  1925.   len: integer;
  1926. begin
  1927.   Setlength(Result, 255);
  1928.   len := GetClipboardFormatName(Value, PChar(Result), 255);
  1929.   SetLength(Result, len);
  1930. end;
  1931.  
  1932. ////////////////////////////////////////////////////////////////////////////////
  1933. //
  1934. //              Initialization/Finalization
  1935. //
  1936. ////////////////////////////////////////////////////////////////////////////////
  1937. initialization
  1938.   OleInitialize(nil);
  1939.   ShGetMalloc(ShellMalloc);
  1940.   GetClipboardFormatNameStr(0);
  1941.  
  1942. finalization
  1943.   if (FDataFormatMap <> nil) then
  1944.   begin
  1945.     FDataFormatMap.Free;
  1946.     FDataFormatMap := nil;
  1947.   end;
  1948.   if (FDataFormatClasses <> nil) then
  1949.   begin
  1950.     FDataFormatClasses.Free;
  1951.     FDataFormatClasses := nil;
  1952.   end;
  1953.  
  1954.   ShellMalloc := nil;
  1955.  
  1956.   OleUninitialize;
  1957. end.
  1958.  
  1959.