Subversion Repositories decoder

Rev

Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed

  1. unit DragDropFormats;
  2.  
  3. // -----------------------------------------------------------------------------
  4. // Project:         Drag and Drop Component Suite.
  5. // Module:          DragDropFormats
  6. // Description:     Implements commonly used clipboard formats and base classes.
  7. // Version:         4.0
  8. // Date:            18-MAY-2001
  9. // Target:          Win32, Delphi 5-6
  10. // Authors:         Anders Melander, anders@melander.dk, http://www.melander.dk
  11. // Copyright        © 1997-2001 Angus Johnson & Anders Melander
  12. // -----------------------------------------------------------------------------
  13.  
  14. interface
  15.  
  16. uses
  17.   DragDrop,
  18.   Windows,
  19.   Classes,
  20.   ActiveX,
  21.   ShlObj;
  22.  
  23. {$include DragDrop.inc}
  24.  
  25. type
  26. ////////////////////////////////////////////////////////////////////////////////
  27. //
  28. //              TStreamList
  29. //
  30. ////////////////////////////////////////////////////////////////////////////////
  31. // Utility class used by TFileContentsStreamClipboardFormat and
  32. // TDataStreamDataFormat.
  33. ////////////////////////////////////////////////////////////////////////////////
  34.   TStreamList = class(TObject)
  35.   private
  36.     FStreams            : TStrings;
  37.     FOnChanging         : TNotifyEvent;
  38.   protected
  39.     function GetStream(Index: integer): TStream;
  40.     function GetCount: integer;
  41.     procedure Changing;
  42.   public
  43.     constructor Create;
  44.     destructor Destroy; override;
  45.     function Add(Stream: TStream): integer;
  46.     function AddNamed(Stream: TStream; Name: string): integer;
  47.     procedure Delete(Index: integer);
  48.     procedure Clear;
  49.     procedure Assign(Value: TStreamList);
  50.     property Count: integer read GetCount;
  51.     property Streams[Index: integer]: TStream read GetStream; default;
  52.     property Names: TStrings read FStreams;
  53.     property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  54.   end;
  55.  
  56.  
  57. ////////////////////////////////////////////////////////////////////////////////
  58. //
  59. //              TInterfaceList
  60. //
  61. ////////////////////////////////////////////////////////////////////////////////
  62. // List of named interfaces.
  63. // Note: Delphi 5 also implements a TInterfaceList, but it can not be used
  64. // because it doesn't support change notification and isn't extensible.
  65. ////////////////////////////////////////////////////////////////////////////////
  66. // Utility class used by TFileContentsStorageClipboardFormat.
  67. ////////////////////////////////////////////////////////////////////////////////
  68.   TInterfaceList = class(TObject)
  69.   private
  70.     FList               : TStrings;
  71.     FOnChanging         : TNotifyEvent;
  72.   protected
  73.     function GetCount: integer;
  74.     function GetName(Index: integer): string;
  75.     function GetItem(Index: integer): IUnknown;
  76.     procedure Changing;
  77.   public
  78.     constructor Create;
  79.     destructor Destroy; override;
  80.     function Add(Item: IUnknown): integer;
  81.     function AddNamed(Item: IUnknown; Name: string): integer;
  82.     procedure Delete(Index: integer);
  83.     procedure Clear;
  84.     procedure Assign(Value: TInterfaceList);
  85.     property Items[Index: integer]: IUnknown read GetItem; default;
  86.     property Names[Index: integer]: string read GetName;
  87.     property Count: integer read GetCount;
  88.     property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  89.   end;
  90.  
  91. ////////////////////////////////////////////////////////////////////////////////
  92. //
  93. //              TStorageInterfaceList
  94. //
  95. ////////////////////////////////////////////////////////////////////////////////
  96. // List of IStorage interfaces.
  97. // Used by TFileContentsStorageClipboardFormat.
  98. ////////////////////////////////////////////////////////////////////////////////
  99.   TStorageInterfaceList = class(TInterfaceList)
  100.   private
  101.   protected
  102.     function GetStorage(Index: integer): IStorage;
  103.   public
  104.     property Storages[Index: integer]: IStorage read GetStorage; default;
  105.   end;
  106.  
  107. ////////////////////////////////////////////////////////////////////////////////
  108. //
  109. //              TFixedStreamAdapter
  110. //
  111. ////////////////////////////////////////////////////////////////////////////////
  112. // TFixedStreamAdapter fixes several serious bugs in TStreamAdapter.CopyTo.
  113. ////////////////////////////////////////////////////////////////////////////////
  114.   TFixedStreamAdapter = class(TStreamAdapter, IStream)
  115.   public
  116.     function CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint;
  117.       out cbWritten: Largeint): HResult; override; stdcall;
  118.   end;
  119.  
  120. ////////////////////////////////////////////////////////////////////////////////
  121. //
  122. //              TMemoryList
  123. //
  124. ////////////////////////////////////////////////////////////////////////////////
  125. // List which owns the memory blocks it points to.
  126. ////////////////////////////////////////////////////////////////////////////////
  127.   TMemoryList = class(TObject)
  128.   private
  129.     FList: TList;
  130.   protected
  131.     function Get(Index: Integer): Pointer;
  132.     function GetCount: Integer;
  133.   public
  134.     constructor Create;
  135.     destructor Destroy; override;
  136.     function Add(Item: Pointer): Integer;
  137.     procedure Clear;
  138.     procedure Delete(Index: Integer);
  139.     property Count: Integer read GetCount;
  140.     property Items[Index: Integer]: Pointer read Get; default;
  141.   end;
  142.  
  143. ////////////////////////////////////////////////////////////////////////////////
  144. //
  145. //              TCustomSimpleClipboardFormat
  146. //
  147. ////////////////////////////////////////////////////////////////////////////////
  148. // Abstract base class for simple clipboard formats stored in global memory
  149. // or a stream.
  150. ////////////////////////////////////////////////////////////////////////////////
  151. //
  152. // Two different methods of data transfer from the medium to the object are
  153. // supported:
  154. //
  155. //   1) Descendant class reads data from a buffer provided by the base class.
  156. //
  157. //   2) Base class reads data from a buffer provided by the descendant class.
  158. //
  159. // Method #1 only requires that the descedant class implements the ReadData.
  160. //
  161. // Method #2 requires that the descedant class overrides the default
  162. // DoGetDataSized method. The descedant DoGetDataSized method should allocate a
  163. // buffer of the specified size and then call the ReadDataInto method to
  164. // transfer data to the buffer. Even though the ReadData method will not be used
  165. // in this scenario, it should be implemented as an empty method (to avoid
  166. // abstract warnings).
  167. //
  168. // The WriteData method must be implemented regardless of which of the two
  169. // approaches the class implements.
  170. //
  171. ////////////////////////////////////////////////////////////////////////////////
  172.   TCustomSimpleClipboardFormat = class(TClipboardFormat)
  173.   private
  174.   protected
  175.     function DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean; override;
  176.     //: Transfer data from medium to a buffer of the specified size.
  177.     function DoGetDataSized(ADataObject: IDataObject; const AMedium: TStgMedium;
  178.       Size: integer): boolean; virtual;
  179.     //: Transfer data from the specified buffer to the objects storage.
  180.     function ReadData(Value: pointer; Size: integer): boolean; virtual; abstract;
  181.     //: Transfer data from the medium to the specified buffer.
  182.     function ReadDataInto(ADataObject: IDataObject; const AMedium: TStgMedium;
  183.       Buffer: pointer; Size: integer): boolean; virtual;
  184.  
  185.     function DoSetData(const FormatEtcIn: TFormatEtc;
  186.       var AMedium: TStgMedium): boolean; override;
  187.     //: Transfer data from the objects storage to the specified buffer.
  188.     function WriteData(Value: pointer; Size: integer): boolean; virtual; abstract;
  189.     function GetSize: integer; virtual; abstract;
  190.   public
  191.     constructor Create; override;
  192.   end;
  193.  
  194.  
  195. ////////////////////////////////////////////////////////////////////////////////
  196. //
  197. //              TCustomStringClipboardFormat
  198. //
  199. ////////////////////////////////////////////////////////////////////////////////
  200. // Abstract base class for simple clipboard formats.
  201. // The data is stored in a string.
  202. ////////////////////////////////////////////////////////////////////////////////
  203.   TCustomStringClipboardFormat = class(TCustomSimpleClipboardFormat)
  204.   private
  205.     FData: string;
  206.     FTrimZeroes: boolean;
  207.   protected
  208.     function ReadData(Value: pointer; Size: integer): boolean; override;
  209.     function WriteData(Value: pointer; Size: integer): boolean; override;
  210.     function GetSize: integer; override;
  211.  
  212.     function GetString: string;
  213.     procedure SetString(const Value: string);
  214.     property Data: string read FData write FData; // DONE : Why is SetString used instead of FData?
  215.   public
  216.     procedure Clear; override;
  217.     function HasData: boolean; override;
  218.     property TrimZeroes: boolean read FTrimZeroes write FTrimZeroes;
  219.   end;
  220.  
  221. ////////////////////////////////////////////////////////////////////////////////
  222. //
  223. //              TCustomStringListClipboardFormat
  224. //
  225. ////////////////////////////////////////////////////////////////////////////////
  226. // Abstract base class for simple cr/lf delimited string clipboard formats.
  227. // The data is stored in a TStringList.
  228. ////////////////////////////////////////////////////////////////////////////////
  229.   TCustomStringListClipboardFormat = class(TCustomSimpleClipboardFormat)
  230.   private
  231.     FLines              : TStrings;
  232.   protected
  233.     function ReadData(Value: pointer; Size: integer): boolean; override;
  234.     function WriteData(Value: pointer; Size: integer): boolean; override;
  235.     function GetSize: integer; override;
  236.  
  237.     function GetLines: TStrings;
  238.     property Lines: TStrings read FLines;
  239.   public
  240.     constructor Create; override;
  241.     destructor Destroy; override;
  242.     procedure Clear; override;
  243.     function HasData: boolean; override;
  244.   end;
  245.  
  246. ////////////////////////////////////////////////////////////////////////////////
  247. //
  248. //              TCustomTextClipboardFormat
  249. //
  250. ////////////////////////////////////////////////////////////////////////////////
  251. // Abstract base class for simple text based clipboard formats.
  252. ////////////////////////////////////////////////////////////////////////////////
  253.   TCustomTextClipboardFormat = class(TCustomStringClipboardFormat)
  254.   private
  255.   protected
  256.     function GetSize: integer; override;
  257.     property Text: string read GetString write SetString;
  258.   public
  259.     constructor Create; override;
  260.   end;
  261.  
  262. ////////////////////////////////////////////////////////////////////////////////
  263. //
  264. //              TCustomWideTextClipboardFormat
  265. //
  266. ////////////////////////////////////////////////////////////////////////////////
  267. // Abstract base class for simple wide string clipboard formats storing the data
  268. // in a wide string.
  269. ////////////////////////////////////////////////////////////////////////////////
  270.   TCustomWideTextClipboardFormat = class(TCustomSimpleClipboardFormat)
  271.   private
  272.     FText               : WideString;
  273.   protected
  274.     function ReadData(Value: pointer; Size: integer): boolean; override;
  275.     function WriteData(Value: pointer; Size: integer): boolean; override;
  276.     function GetSize: integer; override;
  277.  
  278.     function GetText: WideString;
  279.     procedure SetText(const Value: WideString);
  280.     property Text: WideString read FText write FText;
  281.   public
  282.     procedure Clear; override;
  283.     function HasData: boolean; override;
  284.   end;
  285.  
  286. ////////////////////////////////////////////////////////////////////////////////
  287. //
  288. //              TTextClipboardFormat
  289. //
  290. ////////////////////////////////////////////////////////////////////////////////
  291.   TTextClipboardFormat = class(TCustomTextClipboardFormat)
  292.   public
  293.     function GetClipboardFormat: TClipFormat; override;
  294.     property Text;
  295.   end;
  296.  
  297. ////////////////////////////////////////////////////////////////////////////////
  298. //
  299. //              TCustomDWORDClipboardFormat
  300. //
  301. ////////////////////////////////////////////////////////////////////////////////
  302.   TCustomDWORDClipboardFormat = class(TCustomSimpleClipboardFormat)
  303.   private
  304.     FValue              : DWORD;
  305.   protected
  306.     function ReadData(Value: pointer; Size: integer): boolean; override;
  307.     function WriteData(Value: pointer; Size: integer): boolean; override;
  308.     function GetSize: integer; override;
  309.  
  310.     function GetValueDWORD: DWORD;
  311.     procedure SetValueDWORD(Value: DWORD);
  312.     function GetValueInteger: integer;
  313.     procedure SetValueInteger(Value: integer);
  314.     function GetValueLongInt: longInt;
  315.     procedure SetValueLongInt(Value: longInt);
  316.     function GetValueBoolean: boolean;
  317.     procedure SetValueBoolean(Value: boolean);
  318.   public
  319.     procedure Clear; override;
  320.   end;
  321.  
  322. ////////////////////////////////////////////////////////////////////////////////
  323. //
  324. //              TFileGroupDescritorClipboardFormat
  325. //
  326. ////////////////////////////////////////////////////////////////////////////////
  327.   TFileGroupDescritorClipboardFormat = class(TCustomSimpleClipboardFormat)
  328.   private
  329.     FFileGroupDescriptor        : PFileGroupDescriptor;
  330.   protected
  331.     function ReadData(Value: pointer; Size: integer): boolean; override;
  332.     function WriteData(Value: pointer; Size: integer): boolean; override;
  333.     function GetSize: integer; override;
  334.   public
  335.     function GetClipboardFormat: TClipFormat; override;
  336.     destructor Destroy; override;
  337.     procedure Clear; override;
  338.     function HasData: boolean; override;
  339.     property FileGroupDescriptor: PFileGroupDescriptor read FFileGroupDescriptor;
  340.     procedure CopyFrom(AFileGroupDescriptor: PFileGroupDescriptor);
  341.   end;
  342.  
  343. ////////////////////////////////////////////////////////////////////////////////
  344. //
  345. //              TFileGroupDescritorWClipboardFormat
  346. //
  347. ////////////////////////////////////////////////////////////////////////////////
  348.   // Warning: TFileGroupDescriptorW has wrong declaration in ShlObj.pas!
  349.   TFileGroupDescriptorW = record
  350.     cItems: UINT;
  351.     fgd: array[0..0] of TFileDescriptorW;
  352.   end;
  353.  
  354.   PFileGroupDescriptorW = ^TFileGroupDescriptorW;
  355.  
  356.   TFileGroupDescritorWClipboardFormat = class(TCustomSimpleClipboardFormat)
  357.   private
  358.     FFileGroupDescriptor        : PFileGroupDescriptorW;
  359.   protected
  360.     function ReadData(Value: pointer; Size: integer): boolean; override;
  361.     function WriteData(Value: pointer; Size: integer): boolean; override;
  362.     function GetSize: integer; override;
  363.   public
  364.     function GetClipboardFormat: TClipFormat; override;
  365.     destructor Destroy; override;
  366.     procedure Clear; override;
  367.     function HasData: boolean; override;
  368.     property FileGroupDescriptor: PFileGroupDescriptorW read FFileGroupDescriptor;
  369.     procedure CopyFrom(AFileGroupDescriptor: PFileGroupDescriptorW);
  370.   end;
  371.  
  372. ////////////////////////////////////////////////////////////////////////////////
  373. //
  374. //              TFileContentsClipboardFormat
  375. //
  376. ////////////////////////////////////////////////////////////////////////////////
  377. // Note: File contents must be zero terminated, so we descend from
  378. // TCustomTextClipboardFormat instead of TCustomStringClipboardFormat.
  379. ////////////////////////////////////////////////////////////////////////////////
  380.   TFileContentsClipboardFormat = class(TCustomTextClipboardFormat)
  381.   public
  382.     function GetClipboardFormat: TClipFormat; override;
  383.     constructor Create; override;
  384.     property Data;
  385.   end;
  386.  
  387. ////////////////////////////////////////////////////////////////////////////////
  388. //
  389. //              TFileContentsStreamClipboardFormat
  390. //
  391. ////////////////////////////////////////////////////////////////////////////////
  392.   TFileContentsStreamClipboardFormat = class(TClipboardFormat)
  393.   private
  394.     FStreams: TStreamList;
  395.   protected
  396.   public
  397.     constructor Create; override;
  398.     destructor Destroy; override;
  399.     function GetClipboardFormat: TClipFormat; override;
  400.     function GetData(DataObject: IDataObject): boolean; override;
  401.     procedure Clear; override;
  402.     function HasData: boolean; override;
  403.     function AssignTo(Dest: TCustomDataFormat): boolean; override;
  404.     property Streams: TStreamList read FStreams;
  405.   end;
  406.  
  407. ////////////////////////////////////////////////////////////////////////////////
  408. //
  409. //              TFileContentsStreamOnDemandClipboardFormat
  410. //
  411. ////////////////////////////////////////////////////////////////////////////////
  412. // Yeah, it's a long name, but I like my names descriptive.
  413. ////////////////////////////////////////////////////////////////////////////////
  414.   TVirtualFileStreamDataFormat = class;
  415.   TFileContentsStreamOnDemandClipboardFormat = class;
  416.  
  417.   TOnGetStreamEvent = procedure(Sender: TFileContentsStreamOnDemandClipboardFormat;
  418.     Index: integer; out AStream: IStream) of object;
  419.  
  420.   TFileContentsStreamOnDemandClipboardFormat = class(TClipboardFormat)
  421.   private
  422.     FOnGetStream: TOnGetStreamEvent;
  423.     FGotData: boolean;
  424.     FDataRequested: boolean;
  425.   protected
  426.     function DoSetData(const FormatEtcIn: TFormatEtc;
  427.       var AMedium: TStgMedium): boolean; override;
  428.   public
  429.     constructor Create; override;
  430.     destructor Destroy; override;
  431.     function GetClipboardFormat: TClipFormat; override;
  432.     function GetData(DataObject: IDataObject): boolean; override;
  433.     procedure Clear; override;
  434.     function HasData: boolean; override;
  435.     function AssignTo(Dest: TCustomDataFormat): boolean; override;
  436.     function Assign(Source: TCustomDataFormat): boolean; override;
  437.  
  438.     function GetStream(Index: integer): IStream;
  439.  
  440.     property OnGetStream: TOnGetStreamEvent read FOnGetStream write FOnGetStream;
  441.   end;
  442.  
  443. ////////////////////////////////////////////////////////////////////////////////
  444. //
  445. //              TFileContentsStorageClipboardFormat
  446. //
  447. ////////////////////////////////////////////////////////////////////////////////
  448.   TFileContentsStorageClipboardFormat = class(TClipboardFormat)
  449.   private
  450.     FStorages           : TStorageInterfaceList;
  451.   protected
  452.   public
  453.     constructor Create; override;
  454.     destructor Destroy; override;
  455.     function GetClipboardFormat: TClipFormat; override;
  456.     function GetData(DataObject: IDataObject): boolean; override;
  457.     procedure Clear; override;
  458.     function HasData: boolean; override;
  459.     function AssignTo(Dest: TCustomDataFormat): boolean; override;
  460.     property Storages: TStorageInterfaceList read FStorages;
  461.   end;
  462.  
  463. ////////////////////////////////////////////////////////////////////////////////
  464. //
  465. //              TPreferredDropEffectClipboardFormat
  466. //
  467. ////////////////////////////////////////////////////////////////////////////////
  468.   TPreferredDropEffectClipboardFormat = class(TCustomDWORDClipboardFormat)
  469.   public
  470.     class function GetClassClipboardFormat: TClipFormat;
  471.     function GetClipboardFormat: TClipFormat; override;
  472.     function HasData: boolean; override;
  473.     property Value: longInt read GetValueLongInt write SetValueLongInt;
  474.   end;
  475.  
  476. ////////////////////////////////////////////////////////////////////////////////
  477. //
  478. //              TPerformedDropEffectClipboardFormat
  479. //
  480. ////////////////////////////////////////////////////////////////////////////////
  481.   TPerformedDropEffectClipboardFormat = class(TCustomDWORDClipboardFormat)
  482.   public
  483.     function GetClipboardFormat: TClipFormat; override;
  484.     property Value: longInt read GetValueLongInt write SetValueLongInt;
  485.   end;
  486.  
  487. ////////////////////////////////////////////////////////////////////////////////
  488. //
  489. //              TLogicalPerformedDropEffectClipboardFormat
  490. //
  491. ////////////////////////////////////////////////////////////////////////////////
  492. // Microsoft's latest (so far) "logical" solution to the never ending attempts
  493. // of reporting back to the source which operation actually took place. Sigh!
  494. ////////////////////////////////////////////////////////////////////////////////
  495.   TLogicalPerformedDropEffectClipboardFormat = class(TCustomDWORDClipboardFormat)
  496.   public
  497.     function GetClipboardFormat: TClipFormat; override;
  498.     property Value: longInt read GetValueLongInt write SetValueLongInt;
  499.   end;
  500.  
  501. ////////////////////////////////////////////////////////////////////////////////
  502. //
  503. //              TPasteSuccededClipboardFormat
  504. //
  505. ////////////////////////////////////////////////////////////////////////////////
  506.   TPasteSuccededClipboardFormat = class(TCustomDWORDClipboardFormat)
  507.   public
  508.     function GetClipboardFormat: TClipFormat; override;
  509.     property Value: longInt read GetValueLongInt write SetValueLongInt;
  510.   end;
  511.  
  512. ////////////////////////////////////////////////////////////////////////////////
  513. //
  514. //              TInDragLoopClipboardFormat
  515. //
  516. ////////////////////////////////////////////////////////////////////////////////
  517.   TInShellDragLoopClipboardFormat = class(TCustomDWORDClipboardFormat)
  518.   public
  519.     function GetClipboardFormat: TClipFormat; override;
  520.     property InShellDragLoop: boolean read GetValueBoolean write SetValueBoolean;
  521.   end;
  522.  
  523. ////////////////////////////////////////////////////////////////////////////////
  524. //
  525. //              TTargetCLSIDClipboardFormat
  526. //
  527. ////////////////////////////////////////////////////////////////////////////////
  528.   TTargetCLSIDClipboardFormat = class(TCustomSimpleClipboardFormat)
  529.   private
  530.     FCLSID: TCLSID;
  531.   protected
  532.     function ReadData(Value: pointer; Size: integer): boolean; override;
  533.     function WriteData(Value: pointer; Size: integer): boolean; override;
  534.     function GetSize: integer; override;
  535.   public
  536.     function GetClipboardFormat: TClipFormat; override;
  537.     procedure Clear; override;
  538.     function HasData: boolean; override;
  539.     property CLSID: TCLSID read FCLSID write FCLSID;
  540.   end;
  541.  
  542. ////////////////////////////////////////////////////////////////////////////////
  543. ////////////////////////////////////////////////////////////////////////////////
  544. ////////////////////////////////////////////////////////////////////////////////
  545.  
  546.  
  547. ////////////////////////////////////////////////////////////////////////////////
  548. //
  549. //              TTextDataFormat
  550. //
  551. ////////////////////////////////////////////////////////////////////////////////
  552.   TTextDataFormat = class(TCustomDataFormat)
  553.   private
  554.     FText               : string;
  555.   protected
  556.     procedure SetText(const Value: string);
  557.   public
  558.     function Assign(Source: TClipboardFormat): boolean; override;
  559.     function AssignTo(Dest: TClipboardFormat): boolean; override;
  560.     procedure Clear; override;
  561.     function HasData: boolean; override;
  562.     function NeedsData: boolean; override;
  563.     property Text: string read FText write SetText;
  564.   end;
  565.  
  566. ////////////////////////////////////////////////////////////////////////////////
  567. //
  568. //              TDataStreamDataFormat
  569. //
  570. ////////////////////////////////////////////////////////////////////////////////
  571.   TDataStreamDataFormat = class(TCustomDataFormat)
  572.   private
  573.     FStreams            : TStreamList;
  574.   public
  575.     constructor Create(AOwner: TDragDropComponent); override;
  576.     destructor Destroy; override;
  577.     procedure Clear; override;
  578.     function HasData: boolean; override;
  579.     function NeedsData: boolean; override;
  580.     property Streams: TStreamList read FStreams;
  581.   end;
  582.  
  583. ////////////////////////////////////////////////////////////////////////////////
  584. //
  585. //              TVirtualFileStreamDataFormat
  586. //
  587. ////////////////////////////////////////////////////////////////////////////////
  588.   TVirtualFileStreamDataFormat = class(TCustomDataFormat)
  589.   private
  590.     FFileDescriptors: TMemoryList;
  591.     FFileNames: TStrings;
  592.     FFileContentsClipboardFormat: TFileContentsStreamOnDemandClipboardFormat;
  593.     FFileGroupDescritorClipboardFormat: TFileGroupDescritorClipboardFormat;
  594.     FHasContents: boolean;
  595.   protected
  596.     procedure SetFileNames(const Value: TStrings);
  597.     function GetOnGetStream: TOnGetStreamEvent;
  598.     procedure SetOnGetStream(const Value: TOnGetStreamEvent);
  599.   public
  600.     constructor Create(AOwner: TDragDropComponent); override;
  601.     destructor Destroy; override;
  602.  
  603.     function Assign(Source: TClipboardFormat): boolean; override;
  604.     function AssignTo(Dest: TClipboardFormat): boolean; override;
  605.     procedure Clear; override;
  606.     function HasData: boolean; override;
  607.     function NeedsData: boolean; override;
  608.     property FileDescriptors: TMemoryList read FFileDescriptors;
  609.     property FileNames: TStrings read FFileNames write SetFileNames;
  610.     property FileContentsClipboardFormat: TFileContentsStreamOnDemandClipboardFormat
  611.       read FFileContentsClipboardFormat;
  612.     property FileGroupDescritorClipboardFormat: TFileGroupDescritorClipboardFormat
  613.       read FFileGroupDescritorClipboardFormat;
  614.     property OnGetStream: TOnGetStreamEvent read GetOnGetStream write SetOnGetStream;
  615.   end;
  616.  
  617. ////////////////////////////////////////////////////////////////////////////////
  618. //
  619. //              TFeedbackDataFormat
  620. //
  621. ////////////////////////////////////////////////////////////////////////////////
  622. // Data used for communication between source and target.
  623. // Only used by the drop source.
  624. ////////////////////////////////////////////////////////////////////////////////
  625.   TFeedbackDataFormat = class(TCustomDataFormat)
  626.   private
  627.     FPreferredDropEffect: longInt;
  628.     FPerformedDropEffect: longInt;
  629.     FLogicalPerformedDropEffect: longInt;
  630.     FPasteSucceded: longInt;
  631.     FInShellDragLoop: boolean;
  632.     FGotInShellDragLoop: boolean;
  633.     FTargetCLSID: TCLSID;
  634.   protected
  635.     procedure SetInShellDragLoop(const Value: boolean);
  636.     procedure SetPasteSucceded(const Value: longInt);
  637.     procedure SetPerformedDropEffect(const Value: longInt);
  638.     procedure SetPreferredDropEffect(const Value: longInt);
  639.     procedure SetTargetCLSID(const Value: TCLSID);
  640.     procedure SetLogicalPerformedDropEffect(const Value: Integer);
  641.   public
  642.     function Assign(Source: TClipboardFormat): boolean; override;
  643.     function AssignTo(Dest: TClipboardFormat): boolean; override;
  644.     procedure Clear; override;
  645.     function HasData: boolean; override;
  646.     function NeedsData: boolean; override;
  647.     property PreferredDropEffect: longInt read FPreferredDropEffect
  648.       write SetPreferredDropEffect;
  649.     property PerformedDropEffect: longInt read FPerformedDropEffect
  650.       write SetPerformedDropEffect;
  651.     property LogicalPerformedDropEffect: longInt read FLogicalPerformedDropEffect
  652.       write SetLogicalPerformedDropEffect;
  653.     property PasteSucceded: longInt read FPasteSucceded write SetPasteSucceded;
  654.     property InShellDragLoop: boolean read FInShellDragLoop
  655.       write SetInShellDragLoop;
  656.     property TargetCLSID: TCLSID read FTargetCLSID write SetTargetCLSID;
  657.   end;
  658.  
  659.  
  660. ////////////////////////////////////////////////////////////////////////////////
  661. //
  662. //              TGenericClipboardFormat & TGenericDataFormat
  663. //
  664. ////////////////////////////////////////////////////////////////////////////////
  665. // TGenericDataFormat is not used internally by the library, but can be used to
  666. // add support for new formats with a minimum of custom code.
  667. // Even though TGenericDataFormat represents the data as a string, it can be
  668. // used to transfer any kind of data.
  669. // TGenericClipboardFormat is used internally by TGenericDataFormat but can also
  670. // be used by other TCustomDataFormat descendants or as a base class for new
  671. // clipboard formats.
  672. // Note that you should not register TGenericClipboardFormat as compatible with
  673. // TGenericDataFormat.
  674. // To use TGenericDataFormat, all you need to do is instantiate it against
  675. // the desired component and register your custom clipboard formats:
  676. //
  677. // var
  678. //   MyCustomData: TGenericDataFormat;
  679. //
  680. //   MyCustomData := TGenericDataFormat.Create(DropTextTarget1);
  681. //   MyCustomData.AddFormat('MyCustomFormat');
  682. //
  683. ////////////////////////////////////////////////////////////////////////////////
  684.   TGenericDataFormat = class(TCustomDataFormat)
  685.   private
  686.     FData               : string;
  687.   protected
  688.     function GetSize: integer;
  689.     procedure DoSetData(const Value: string);
  690.   public
  691.     procedure Clear; override;
  692.     function HasData: boolean; override;
  693.     function NeedsData: boolean; override;
  694.     procedure AddFormat(const AFormat: string);
  695.     procedure SetDataHere(const AData; ASize: integer);
  696.     function GetDataHere(var AData; ASize: integer): integer;
  697.     property Data: string read FData write DoSetData;
  698.     property Size: integer read GetSize;
  699.   end;
  700.  
  701.   TGenericClipboardFormat = class(TCustomStringClipboardFormat)
  702.   private
  703.     FFormat: string;
  704.   protected
  705.     procedure SetClipboardFormatName(const Value: string); override;
  706.     function GetClipboardFormatName: string; override;
  707.     function GetClipboardFormat: TClipFormat; override;
  708.   public
  709.     function Assign(Source: TCustomDataFormat): boolean; override;
  710.     function AssignTo(Dest: TCustomDataFormat): boolean; override;
  711.     property Data;
  712.   end;
  713.  
  714.  
  715.  
  716. ////////////////////////////////////////////////////////////////////////////////
  717. ////////////////////////////////////////////////////////////////////////////////
  718. //
  719. //                      IMPLEMENTATION
  720. //
  721. ////////////////////////////////////////////////////////////////////////////////
  722. ////////////////////////////////////////////////////////////////////////////////
  723. implementation
  724.  
  725. uses
  726.   DropSource,
  727.   DropTarget,
  728.   SysUtils;
  729.  
  730. ////////////////////////////////////////////////////////////////////////////////
  731. //
  732. //              TStreamList
  733. //
  734. ////////////////////////////////////////////////////////////////////////////////
  735. constructor TStreamList.Create;
  736. begin
  737.   inherited Create;
  738.   FStreams := TStringList.Create;
  739. end;
  740.  
  741. destructor TStreamList.Destroy;
  742. begin
  743.   Clear;
  744.   FStreams.Free;
  745.   inherited Destroy;
  746. end;
  747.  
  748. procedure TStreamList.Changing;
  749. begin
  750.   if (Assigned(OnChanging)) then
  751.     OnChanging(Self);
  752. end;
  753.  
  754. function TStreamList.GetStream(Index: integer): TStream;
  755. begin
  756.   Result := TStream(FStreams.Objects[Index]);
  757. end;
  758.  
  759. function TStreamList.Add(Stream: TStream): integer;
  760. begin
  761.   Result := AddNamed(Stream, '');
  762. end;
  763.  
  764. function TStreamList.AddNamed(Stream: TStream; Name: string): integer;
  765. begin
  766.   Changing;
  767.   Result := FStreams.AddObject(Name, Stream);
  768. end;
  769.  
  770. function TStreamList.GetCount: integer;
  771. begin
  772.   Result := FStreams.Count;
  773. end;
  774.  
  775. procedure TStreamList.Assign(Value: TStreamList);
  776. begin
  777.   Clear;
  778.   FStreams.Assign(Value.Names);
  779.   // Transfer ownership of objects
  780.   Value.FStreams.Clear;
  781. end;
  782.  
  783. procedure TStreamList.Delete(Index: integer);
  784. begin
  785.   Changing;
  786.   FStreams.Delete(Index);
  787. end;
  788.  
  789. procedure TStreamList.Clear;
  790. var
  791.   i                     : integer;
  792. begin
  793.   Changing;
  794.   for i := 0 to FStreams.Count-1 do
  795.     if (FStreams.Objects[i] <> nil) then
  796.       FStreams.Objects[i].Free;
  797.   FStreams.Clear;
  798. end;
  799.  
  800.  
  801. ////////////////////////////////////////////////////////////////////////////////
  802. //
  803. //              TInterfaceList
  804. //
  805. ////////////////////////////////////////////////////////////////////////////////
  806. constructor TInterfaceList.Create;
  807. begin
  808.   inherited Create;
  809.   FList := TStringList.Create;
  810. end;
  811.  
  812. destructor TInterfaceList.Destroy;
  813. begin
  814.   Clear;
  815.   FList.Free;
  816.   inherited Destroy;
  817. end;
  818.  
  819. function TInterfaceList.Add(Item: IUnknown): integer;
  820. begin
  821.   Result := AddNamed(Item, '');
  822. end;
  823.  
  824. function TInterfaceList.AddNamed(Item: IUnknown; Name: string): integer;
  825. begin
  826.   Changing;
  827.   with FList do
  828.   begin
  829.     Result := AddObject(Name, nil);
  830.     Objects[Result] := TObject(Item);
  831.     Item._AddRef;
  832.   end;
  833. end;
  834.  
  835. procedure TInterfaceList.Changing;
  836. begin
  837.   if (Assigned(OnChanging)) then
  838.     OnChanging(Self);
  839. end;
  840.  
  841. procedure TInterfaceList.Clear;
  842. var
  843.   i                     : Integer;
  844.   p                     : pointer;
  845. begin
  846.   Changing;
  847.   with FList do
  848.   begin
  849.     for i := 0 to Count - 1 do
  850.     begin
  851.       p := Objects[i];
  852.       IUnknown(p) := nil;
  853.     end;
  854.     Clear;
  855.   end;
  856. end;
  857.  
  858. procedure TInterfaceList.Assign(Value: TInterfaceList);
  859. var
  860.   i                     : Integer;
  861. begin
  862.   Changing;
  863.   for i := 0 to Value.Count - 1 do
  864.     AddNamed(Value.Items[i], Value.Names[i]);
  865. end;
  866.  
  867. procedure TInterfaceList.Delete(Index: integer);
  868. var
  869.   p                     : pointer;
  870. begin
  871.   Changing;
  872.   with FList do
  873.   begin
  874.     p := Objects[Index];
  875.     IUnknown(p) := nil;
  876.     Delete(Index);
  877.   end;
  878. end;
  879.  
  880. function TInterfaceList.GetCount: integer;
  881. begin
  882.   Result := FList.Count;
  883. end;
  884.  
  885. function TInterfaceList.GetName(Index: integer): string;
  886. begin
  887.   Result := FList[Index];
  888. end;
  889.  
  890. function TInterfaceList.GetItem(Index: integer): IUnknown;
  891. var
  892.   p                     : pointer;
  893. begin
  894.   p := FList.Objects[Index];
  895.   Result := IUnknown(p);
  896. end;
  897.  
  898.  
  899. ////////////////////////////////////////////////////////////////////////////////
  900. //
  901. //              TStorageInterfaceList
  902. //
  903. ////////////////////////////////////////////////////////////////////////////////
  904. function TStorageInterfaceList.GetStorage(Index: integer): IStorage;
  905. begin
  906.   Result := IStorage(Items[Index]);
  907. end;
  908.  
  909.  
  910. ////////////////////////////////////////////////////////////////////////////////
  911. //
  912. //              TMemoryList
  913. //
  914. ////////////////////////////////////////////////////////////////////////////////
  915. function TMemoryList.Add(Item: Pointer): Integer;
  916. begin
  917.   Result := FList.Add(Item);
  918. end;
  919.  
  920. procedure TMemoryList.Clear;
  921. var
  922.   i: integer;
  923. begin
  924.   for i := FList.Count-1 downto 0 do
  925.     Delete(i);
  926. end;
  927.  
  928. constructor TMemoryList.Create;
  929. begin
  930.   inherited Create;
  931.   FList := TList.Create;
  932. end;
  933.  
  934. procedure TMemoryList.Delete(Index: Integer);
  935. begin
  936.   Freemem(FList[Index]);
  937.   FList.Delete(Index);
  938. end;
  939.  
  940. destructor TMemoryList.Destroy;
  941. begin
  942.   FList.Free;
  943.   inherited Destroy;
  944. end;
  945.  
  946. function TMemoryList.Get(Index: Integer): Pointer;
  947. begin
  948.   Result := FList[Index];
  949. end;
  950.  
  951. function TMemoryList.GetCount: Integer;
  952. begin
  953.   Result := FList.Count;
  954. end;
  955.  
  956.  
  957. ////////////////////////////////////////////////////////////////////////////////
  958. //
  959. //              TFixedStreamAdapter
  960. //
  961. ////////////////////////////////////////////////////////////////////////////////
  962. function TFixedStreamAdapter.CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint;
  963.   out cbWritten: Largeint): HResult;
  964. const
  965.   MaxBufSize = 1024 * 1024;  // 1mb
  966. var
  967.   Buffer: Pointer;
  968.   BufSize, BurstReadSize, BurstWriteSize: Integer;
  969.   BytesRead, BytesWritten, BurstWritten: LongInt;
  970. begin
  971.   Result := S_OK;
  972.   BytesRead := 0;
  973.   BytesWritten := 0;
  974.   try
  975.     if (cb < 0) then
  976.     begin
  977.       // Note: The folowing is a workaround for a design bug in either explorer
  978.       // or the clipboard. See comment in TCustomSimpleClipboardFormat.DoSetData
  979.       // for an explanation.
  980.       if (Stream.Position = Stream.Size) then
  981.         Stream.Position := 0;
  982.  
  983.       cb := Stream.Size - Stream.Position;
  984.     end;
  985.     if cb > MaxBufSize then
  986.       BufSize := MaxBufSize
  987.     else
  988.       BufSize := Integer(cb);
  989.     GetMem(Buffer, BufSize);
  990.     try
  991.       while cb > 0 do
  992.       begin
  993.         if cb > BufSize then
  994.           BurstReadSize := BufSize
  995.         else
  996.           BurstReadSize := cb;
  997.  
  998.         BurstWriteSize := Stream.Read(Buffer^, BurstReadSize);
  999.         if (BurstWriteSize = 0) then
  1000.           break;
  1001.         Inc(BytesRead, BurstWriteSize);
  1002.         BurstWritten := 0;
  1003.         Result := stm.Write(Buffer, BurstWriteSize, @BurstWritten);
  1004.         Inc(BytesWritten, BurstWritten);
  1005.         if (Result = S_OK) and (Integer(BurstWritten) <> BurstWriteSize) then
  1006.           Result := E_FAIL;
  1007.         if Result <> S_OK then
  1008.           Exit;
  1009.         Dec(cb, BurstWritten);
  1010.       end;
  1011.     finally
  1012.       FreeMem(Buffer);
  1013.       if (@cbWritten <> nil) then
  1014.         cbWritten := BytesWritten;
  1015.       if (@cbRead <> nil) then
  1016.         cbRead := BytesRead;
  1017.     end;
  1018.   except
  1019.     Result := E_UNEXPECTED;
  1020.   end;
  1021. end;
  1022.  
  1023.  
  1024. ////////////////////////////////////////////////////////////////////////////////
  1025. //
  1026. //              TCustomSimpleClipboardFormat
  1027. //
  1028. ////////////////////////////////////////////////////////////////////////////////
  1029. constructor TCustomSimpleClipboardFormat.Create;
  1030. begin
  1031.   CreateFormat(TYMED_HGLOBAL or TYMED_ISTREAM);
  1032. end;
  1033.  
  1034. function TCustomSimpleClipboardFormat.DoGetData(ADataObject: IDataObject;
  1035.   const AMedium: TStgMedium): boolean;
  1036. var
  1037.   Stream                : IStream;
  1038.   StatStg               : TStatStg;
  1039.   Size                  : integer;
  1040. begin
  1041.   // Get size from HGlobal.
  1042.   if (AMedium.tymed and TYMED_HGLOBAL <> 0) then
  1043.   begin
  1044.     Size := GlobalSize(AMedium.HGlobal);
  1045.     Result := True;
  1046.   end else
  1047.   // Get size from IStream.
  1048.   if (AMedium.tymed and TYMED_ISTREAM <> 0) then
  1049.   begin
  1050.     Stream := IStream(AMedium.stm);
  1051.     Result := (Stream <> nil) and (Stream.Stat(StatStg, STATFLAG_NONAME) = S_OK);
  1052.     Size := StatStg.cbSize;
  1053.     Stream := nil; // Not really nescessary.
  1054.   end else
  1055.   begin
  1056.     Size := 0;
  1057.     Result := False;
  1058.   end;
  1059.  
  1060.   if (Result) and (Size > 0) then
  1061.   begin
  1062.     // Read the given amount of data.
  1063.     Result := DoGetDataSized(ADataObject, AMedium, Size);
  1064.   end;
  1065. end;
  1066.  
  1067. function TCustomSimpleClipboardFormat.DoGetDataSized(ADataObject: IDataObject;
  1068.   const AMedium: TStgMedium; Size: integer): boolean;
  1069. var
  1070.   Buffer: pointer;
  1071.   Stream: IStream;
  1072.   Remaining: longInt;
  1073.   Chunk: longInt;
  1074.   pChunk: PChar;
  1075. begin
  1076.   if (Size > 0) then
  1077.   begin
  1078.     (*
  1079.     ** In this method we prefer TYMED_HGLOBAL over TYMED_ISTREAM and thus check
  1080.     ** for TYMED_HGLOBAL first.
  1081.     *)
  1082.  
  1083.     // Read data from HGlobal
  1084.     if (AMedium.tymed and TYMED_HGLOBAL <> 0) then
  1085.     begin
  1086.       // Use global memory as buffer
  1087.       Buffer := GlobalLock(AMedium.HGlobal);
  1088.       try
  1089.         // Read data from buffer into object
  1090.         Result := (Buffer <> nil) and (ReadData(Buffer, Size));
  1091.       finally
  1092.         GlobalUnlock(AMedium.HGlobal);
  1093.       end;
  1094.     end else
  1095.     // Read data from IStream
  1096.     if (AMedium.tymed and TYMED_ISTREAM <> 0) then
  1097.     begin
  1098.       // Allocate buffer
  1099.       GetMem(Buffer, Size);
  1100.       try
  1101.         // Read data from stream into buffer
  1102.         Stream := IStream(AMedium.stm);
  1103.         if (Stream <> nil) then
  1104.         begin
  1105.           Stream.Seek(0, STREAM_SEEK_SET, PLargeuint(nil)^);
  1106.           Result := True;
  1107.           Remaining := Size;
  1108.           pChunk := Buffer;
  1109.           while (Result) and (Remaining > 0) do
  1110.           begin
  1111.             Result := (Stream.Read(pChunk, Remaining, @Chunk) = S_OK);
  1112.             if (Chunk = 0) then
  1113.               break;
  1114.             inc(pChunk, Chunk);
  1115.             dec(Remaining, Chunk);
  1116.           end;
  1117.           Stream := nil; // Not really nescessary.
  1118.         end else
  1119.           Result := False;
  1120.         // Transfer data from buffer into object.
  1121.         Result := Result and (ReadData(Buffer, Size));
  1122.       finally
  1123.         FreeMem(Buffer);
  1124.       end;
  1125.     end else
  1126.       Result := False;
  1127.   end else
  1128.     Result := False;
  1129. end;
  1130.  
  1131. function TCustomSimpleClipboardFormat.ReadDataInto(ADataObject: IDataObject;
  1132.   const AMedium: TStgMedium; Buffer: pointer; Size: integer): boolean;
  1133. var
  1134.   Stream: IStream;
  1135.   p: pointer;
  1136.   Remaining: longInt;
  1137.   Chunk: longInt;
  1138. begin
  1139.   Result := (Buffer <> nil) and (Size > 0);
  1140.   if (Result) then
  1141.   begin
  1142.     // Read data from HGlobal
  1143.     if (AMedium.tymed and TYMED_HGLOBAL <> 0) then
  1144.     begin
  1145.       p := GlobalLock(AMedium.HGlobal);
  1146.       try
  1147.         Result := (p <> nil);
  1148.         if (Result) then
  1149.           Move(p^, Buffer^, Size);
  1150.       finally
  1151.         GlobalUnlock(AMedium.HGlobal);
  1152.       end;
  1153.     end else
  1154.     // Read data from IStream
  1155.     if (AMedium.tymed and TYMED_ISTREAM <> 0) then
  1156.     begin
  1157.       Stream := IStream(AMedium.stm);
  1158.       if (Stream <> nil) then
  1159.       begin
  1160.         Stream.Seek(0, STREAM_SEEK_SET, PLargeuint(nil)^);
  1161.         Remaining := Size;
  1162.         while (Result) and (Remaining > 0) do
  1163.         begin
  1164.           Result := (Stream.Read(Buffer, Remaining, @Chunk) = S_OK);
  1165.           if (Chunk = 0) then
  1166.             break;
  1167.           inc(PChar(Buffer), Chunk);
  1168.           dec(Remaining, Chunk);
  1169.         end;
  1170.       end else
  1171.         Result := False;
  1172.     end else
  1173.       Result := False;
  1174.   end;
  1175. end;
  1176.  
  1177. function TCustomSimpleClipboardFormat.DoSetData(const FormatEtcIn: TFormatEtc;
  1178.   var AMedium: TStgMedium): boolean;
  1179. var
  1180.   p: pointer;
  1181.   Size: integer;
  1182.   Stream: TMemoryStream;
  1183.   // Warning: TStreamAdapter.CopyTo is broken!
  1184.   StreamAdapter: TStreamAdapter;
  1185. begin
  1186.   Result := False;
  1187.  
  1188.   Size := GetSize;
  1189.   if (Size <= 0) then
  1190.     exit;
  1191.  
  1192.   if (FormatEtcIn.tymed and TYMED_ISTREAM <> 0) then
  1193.   begin
  1194.  
  1195.     Stream := TMemoryStream.Create;
  1196.     StreamAdapter := TFixedStreamAdapter.Create(Stream, soOwned);
  1197.  
  1198.     try
  1199.       Stream.Size := Size;
  1200.       Result := WriteData(Stream.Memory, Size);
  1201.       // Note: Conflicting information on which of the following two are correct:
  1202.       //
  1203.       //   1) Stream.Position := Size;
  1204.       //
  1205.       //   2) Stream.Position := 0;
  1206.       //
  1207.       // #1 is required for clipboard operations to succeed; The clipboard uses
  1208.       // a Seek(0, STREAM_SEEK_CUR) to determine the size of the stream.
  1209.       //
  1210.       // #2 is required for shell operations to succeed; The shell uses a
  1211.       // Read(-1) to read all of the stream.
  1212.       //
  1213.       // This library uses a Stream.Stat to determine the size of the stream and
  1214.       // then reads from start to end of stream.
  1215.       //
  1216.       // Since we use #1 (see below), we work around #2 in
  1217.       // TFixedStreamAdapter.CopyTo.
  1218.       if (Result) then
  1219.       begin
  1220.         Stream.Position := Size;
  1221.         IStream(AMedium.stm) := StreamAdapter as IStream;
  1222.       end;
  1223.     except
  1224.       Result := False;
  1225.     end;
  1226.  
  1227.     if (not Result) then
  1228.     begin
  1229.       StreamAdapter.Free;
  1230.       AMedium.stm := nil;
  1231.     end else
  1232.       AMedium.tymed := TYMED_ISTREAM;
  1233.  
  1234.   end else
  1235.   if (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then
  1236.   begin
  1237.  
  1238.     AMedium.hGlobal := GlobalAlloc(GMEM_SHARE or GHND, Size);
  1239.     if (AMedium.hGlobal = 0) then
  1240.       exit;
  1241.  
  1242.     try
  1243.       p := GlobalLock(AMedium.hGlobal);
  1244.       try
  1245.         Result := (p <> nil) and WriteData(p, Size);
  1246.       finally
  1247.         GlobalUnlock(AMedium.hGlobal);
  1248.       end;
  1249.     except
  1250.       Result := False;
  1251.     end;
  1252.  
  1253.     if (not Result) then
  1254.     begin
  1255.       GlobalFree(AMedium.hGlobal);
  1256.       AMedium.hGlobal := 0;
  1257.     end else
  1258.       AMedium.tymed := TYMED_HGLOBAL;
  1259.  
  1260.   end else
  1261.     Result := False;
  1262. end;
  1263.  
  1264.  
  1265. ////////////////////////////////////////////////////////////////////////////////
  1266. //
  1267. //              TCustomStringClipboardFormat
  1268. //
  1269. ////////////////////////////////////////////////////////////////////////////////
  1270. procedure TCustomStringClipboardFormat.Clear;
  1271. begin
  1272.   FData := '';
  1273. end;
  1274.  
  1275. function TCustomStringClipboardFormat.HasData: boolean;
  1276. begin
  1277.   Result := (FData <> '');
  1278. end;
  1279.  
  1280.  
  1281. function TCustomStringClipboardFormat.ReadData(Value: pointer;
  1282.   Size: integer): boolean;
  1283. begin
  1284.   SetLength(FData, Size);
  1285.   Move(Value^, PChar(FData)^, Size);
  1286.  
  1287.   // IE adds a lot of trailing zeroes which is included in the string length.
  1288.   // To avoid confusion, we trim all trailing zeroes but the last (which is
  1289.   // managed automatically by Delphi).
  1290.   // Note that since this work around, if applied generally, would mean that we
  1291.   // couldn't use this class to handle arbitrary binary data (which might
  1292.   // include zeroes), we are required to explicitly enable it in the classes
  1293.   // where we need it (e.g. all TCustomTextClipboardFormat descedants).
  1294.   if (FTrimZeroes) then
  1295.     SetLength(FData, Length(PChar(FData)));
  1296.  
  1297.   Result := True;
  1298. end;
  1299.  
  1300. function TCustomStringClipboardFormat.WriteData(Value: pointer;
  1301.   Size: integer): boolean;
  1302. begin
  1303.   // Transfer string including terminating zero if requested.
  1304.   Result := (Size <= Length(FData)+1);
  1305.   if (Result) then
  1306.     Move(PChar(FData)^, Value^, Size);
  1307. end;
  1308.  
  1309. function TCustomStringClipboardFormat.GetSize: integer;
  1310. begin
  1311.   Result := Length(FData);
  1312. end;
  1313.  
  1314. function TCustomStringClipboardFormat.GetString: string;
  1315. begin
  1316.   Result := FData;
  1317. end;
  1318.  
  1319. procedure TCustomStringClipboardFormat.SetString(const Value: string);
  1320. begin
  1321.   FData := Value;
  1322. end;
  1323.  
  1324.  
  1325. ////////////////////////////////////////////////////////////////////////////////
  1326. //
  1327. //              TCustomStringListClipboardFormat
  1328. //
  1329. ////////////////////////////////////////////////////////////////////////////////
  1330. constructor TCustomStringListClipboardFormat.Create;
  1331. begin
  1332.   inherited Create;
  1333.   FLines := TStringList.Create
  1334. end;
  1335.  
  1336. destructor TCustomStringListClipboardFormat.Destroy;
  1337. begin
  1338.   FLines.Free;
  1339.   inherited Destroy;
  1340. end;
  1341.  
  1342. procedure TCustomStringListClipboardFormat.Clear;
  1343. begin
  1344.   FLines.Clear;
  1345. end;
  1346.  
  1347. function TCustomStringListClipboardFormat.HasData: boolean;
  1348. begin
  1349.   Result := (FLines.Count > 0);
  1350. end;
  1351.  
  1352. function TCustomStringListClipboardFormat.ReadData(Value: pointer;
  1353.   Size: integer): boolean;
  1354. var
  1355.   s                     : string;
  1356. begin
  1357.   SetLength(s, Size+1);
  1358.   Move(Value^, PChar(s)^, Size);
  1359.   s[Size] := #0;
  1360.   FLines.Text := s;
  1361.   Result := True;
  1362. end;
  1363.  
  1364. function TCustomStringListClipboardFormat.WriteData(Value: pointer;
  1365.   Size: integer): boolean;
  1366. var
  1367.   s                     : string;
  1368. begin
  1369.   s := FLines.Text;
  1370.   Result := (Size = Length(s)+1);
  1371.   if (Result) then
  1372.     Move(PChar(s)^, Value^, Size);
  1373. end;
  1374.  
  1375. function TCustomStringListClipboardFormat.GetSize: integer;
  1376. begin
  1377.   Result := Length(FLines.Text)+1;
  1378. end;
  1379.  
  1380. function TCustomStringListClipboardFormat.GetLines: TStrings;
  1381. begin
  1382.   Result := FLines;
  1383. end;
  1384.  
  1385.  
  1386. ////////////////////////////////////////////////////////////////////////////////
  1387. //
  1388. //              TCustomTextClipboardFormat
  1389. //
  1390. ////////////////////////////////////////////////////////////////////////////////
  1391. constructor TCustomTextClipboardFormat.Create;
  1392. begin
  1393.   inherited Create;
  1394.   TrimZeroes := True;
  1395. end;
  1396.  
  1397. function TCustomTextClipboardFormat.GetSize: integer;
  1398. begin
  1399.   Result := inherited GetSize;
  1400.   // Unless the data is already zero terminated, we add a byte to include
  1401.   // the string's implicit terminating zero.
  1402.   if (Data[Result] <> #0) then
  1403.     inc(Result);
  1404. end;
  1405.  
  1406.  
  1407. ////////////////////////////////////////////////////////////////////////////////
  1408. //
  1409. //              TCustomWideTextClipboardFormat
  1410. //
  1411. ////////////////////////////////////////////////////////////////////////////////
  1412. procedure TCustomWideTextClipboardFormat.Clear;
  1413. begin
  1414.   FText := '';
  1415. end;
  1416.  
  1417. function TCustomWideTextClipboardFormat.HasData: boolean;
  1418. begin
  1419.   Result := (FText <> '');
  1420. end;
  1421.  
  1422. function TCustomWideTextClipboardFormat.ReadData(Value: pointer;
  1423.   Size: integer): boolean;
  1424. begin
  1425.   SetLength(FText, Size div 2);
  1426.   Move(Value^, PWideChar(FText)^, Size);
  1427.   Result := True;
  1428. end;
  1429.  
  1430. function TCustomWideTextClipboardFormat.WriteData(Value: pointer;
  1431.   Size: integer): boolean;
  1432. begin
  1433.   Result := (Size <= (Length(FText)+1)*2);
  1434.   if (Result) then
  1435.     Move(PWideChar(FText)^, Value^, Size);
  1436. end;
  1437.  
  1438. function TCustomWideTextClipboardFormat.GetSize: integer;
  1439. begin
  1440.   Result := Length(FText)*2;
  1441.   // Unless the data is already zero terminated, we add two bytes to include
  1442.   // the string's implicit terminating zero.
  1443.   if (FText[Result] <> #0) then
  1444.     inc(Result, 2);
  1445. end;
  1446.  
  1447. function TCustomWideTextClipboardFormat.GetText: WideString;
  1448. begin
  1449.   Result := FText;
  1450. end;
  1451.  
  1452. procedure TCustomWideTextClipboardFormat.SetText(const Value: WideString);
  1453. begin
  1454.   FText := Value;
  1455. end;
  1456.  
  1457.  
  1458. ////////////////////////////////////////////////////////////////////////////////
  1459. //
  1460. //              TTextClipboardFormat
  1461. //
  1462. ////////////////////////////////////////////////////////////////////////////////
  1463. function TTextClipboardFormat.GetClipboardFormat: TClipFormat;
  1464. begin
  1465.   Result := CF_TEXT;
  1466. end;
  1467.  
  1468.  
  1469. ////////////////////////////////////////////////////////////////////////////////
  1470. //
  1471. //              TCustomDWORDClipboardFormat
  1472. //
  1473. ////////////////////////////////////////////////////////////////////////////////
  1474. function TCustomDWORDClipboardFormat.ReadData(Value: pointer;
  1475.   Size: integer): boolean;
  1476. begin
  1477.   FValue := PDWORD(Value)^;
  1478.   Result := True;
  1479. end;
  1480.  
  1481. function TCustomDWORDClipboardFormat.WriteData(Value: pointer;
  1482.   Size: integer): boolean;
  1483. begin
  1484.   Result := (Size = SizeOf(DWORD));
  1485.   if (Result) then
  1486.     PDWORD(Value)^ := FValue;
  1487. end;
  1488.  
  1489. function TCustomDWORDClipboardFormat.GetSize: integer;
  1490. begin
  1491.   Result := SizeOf(DWORD);
  1492. end;
  1493.  
  1494. procedure TCustomDWORDClipboardFormat.Clear;
  1495. begin
  1496.   FValue := 0;
  1497. end;
  1498.  
  1499. function TCustomDWORDClipboardFormat.GetValueDWORD: DWORD;
  1500. begin
  1501.   Result := FValue;
  1502. end;
  1503.  
  1504. procedure TCustomDWORDClipboardFormat.SetValueDWORD(Value: DWORD);
  1505. begin
  1506.   FValue := Value;
  1507. end;
  1508.  
  1509. function TCustomDWORDClipboardFormat.GetValueInteger: integer;
  1510. begin
  1511.   Result := integer(FValue);
  1512. end;
  1513.  
  1514. procedure TCustomDWORDClipboardFormat.SetValueInteger(Value: integer);
  1515. begin
  1516.   FValue := DWORD(Value);
  1517. end;
  1518.  
  1519. function TCustomDWORDClipboardFormat.GetValueLongInt: longInt;
  1520. begin
  1521.   Result := longInt(FValue);
  1522. end;
  1523.  
  1524. procedure TCustomDWORDClipboardFormat.SetValueLongInt(Value: longInt);
  1525. begin
  1526.   FValue := DWORD(Value);
  1527. end;
  1528.  
  1529. function TCustomDWORDClipboardFormat.GetValueBoolean: boolean;
  1530. begin
  1531.   Result := (FValue <> 0);
  1532. end;
  1533.  
  1534. procedure TCustomDWORDClipboardFormat.SetValueBoolean(Value: boolean);
  1535. begin
  1536.   FValue := ord(Value);
  1537. end;
  1538.  
  1539.  
  1540. ////////////////////////////////////////////////////////////////////////////////
  1541. //
  1542. //              TFileGroupDescritorClipboardFormat
  1543. //
  1544. ////////////////////////////////////////////////////////////////////////////////
  1545. var
  1546.   CF_FILEGROUPDESCRIPTOR: TClipFormat = 0;
  1547.  
  1548. function TFileGroupDescritorClipboardFormat.GetClipboardFormat: TClipFormat;
  1549. begin
  1550.   if (CF_FILEGROUPDESCRIPTOR = 0) then
  1551.     CF_FILEGROUPDESCRIPTOR := RegisterClipboardFormat(CFSTR_FILEDESCRIPTOR);
  1552.   Result := CF_FILEGROUPDESCRIPTOR;
  1553. end;
  1554.  
  1555. destructor TFileGroupDescritorClipboardFormat.Destroy;
  1556. begin
  1557.   Clear;
  1558.   inherited Destroy;
  1559. end;
  1560.  
  1561. procedure TFileGroupDescritorClipboardFormat.Clear;
  1562. begin
  1563.   if (FFileGroupDescriptor <> nil) then
  1564.   begin
  1565.     FreeMem(FFileGroupDescriptor);
  1566.     FFileGroupDescriptor := nil;
  1567.   end;
  1568. end;
  1569.  
  1570. function TFileGroupDescritorClipboardFormat.HasData: boolean;
  1571. begin
  1572.   Result := (FFileGroupDescriptor <> nil) and (FFileGroupDescriptor^.cItems <> 0);
  1573. end;
  1574.  
  1575. procedure TFileGroupDescritorClipboardFormat.CopyFrom(AFileGroupDescriptor: PFileGroupDescriptor);
  1576. var
  1577.   Size                  : integer;
  1578. begin
  1579.   Clear;
  1580.   if (AFileGroupDescriptor <> nil) then
  1581.   begin
  1582.     Size := SizeOf(UINT) + AFileGroupDescriptor^.cItems * SizeOf(TFileDescriptor);
  1583.     GetMem(FFileGroupDescriptor, Size);
  1584.     Move(AFileGroupDescriptor^, FFileGroupDescriptor^, Size);
  1585.   end;
  1586. end;
  1587.  
  1588. function TFileGroupDescritorClipboardFormat.GetSize: integer;
  1589. begin
  1590.   if (FFileGroupDescriptor <> nil) then
  1591.     Result := SizeOf(UINT) + FFileGroupDescriptor^.cItems * SizeOf(TFileDescriptor)
  1592.   else
  1593.     Result := 0;
  1594. end;
  1595.  
  1596. function TFileGroupDescritorClipboardFormat.ReadData(Value: pointer;
  1597.   Size: integer): boolean;
  1598. begin
  1599.   // Validate size against count
  1600.   Result :=
  1601.     (Size - SizeOf(UINT)) DIV SizeOf(TFileDescriptor) = integer(PFileGroupDescriptor(Value)^.cItems);
  1602.   if (Result) then
  1603.     CopyFrom(PFileGroupDescriptor(Value));
  1604. end;
  1605.  
  1606. function TFileGroupDescritorClipboardFormat.WriteData(Value: pointer;
  1607.   Size: integer): boolean;
  1608. begin
  1609.   // Validate size against count
  1610.   Result := (FFileGroupDescriptor <> nil) and
  1611.     ((Size - SizeOf(UINT)) DIV SizeOf(TFileDescriptor) = integer(FFileGroupDescriptor^.cItems));
  1612.  
  1613.   if (Result) then
  1614.     Move(FFileGroupDescriptor^, Value^, Size);
  1615. end;
  1616.  
  1617.  
  1618. ////////////////////////////////////////////////////////////////////////////////
  1619. //
  1620. //              TFileGroupDescritorWClipboardFormat
  1621. //
  1622. ////////////////////////////////////////////////////////////////////////////////
  1623. var
  1624.   CF_FILEGROUPDESCRIPTORW: TClipFormat = 0;
  1625.  
  1626. function TFileGroupDescritorWClipboardFormat.GetClipboardFormat: TClipFormat;
  1627. begin
  1628.   if (CF_FILEGROUPDESCRIPTORW = 0) then
  1629.     CF_FILEGROUPDESCRIPTORW := RegisterClipboardFormat(CFSTR_FILEDESCRIPTORW);
  1630.   Result := CF_FILEGROUPDESCRIPTORW;
  1631. end;
  1632.  
  1633. destructor TFileGroupDescritorWClipboardFormat.Destroy;
  1634. begin
  1635.   Clear;
  1636.   inherited Destroy;
  1637. end;
  1638.  
  1639. procedure TFileGroupDescritorWClipboardFormat.Clear;
  1640. begin
  1641.   if (FFileGroupDescriptor <> nil) then
  1642.   begin
  1643.     FreeMem(FFileGroupDescriptor);
  1644.     FFileGroupDescriptor := nil;
  1645.   end;
  1646. end;
  1647.  
  1648. function TFileGroupDescritorWClipboardFormat.HasData: boolean;
  1649. begin
  1650.   Result := (FFileGroupDescriptor <> nil) and (FFileGroupDescriptor^.cItems <> 0);
  1651. end;
  1652.  
  1653. procedure TFileGroupDescritorWClipboardFormat.CopyFrom(AFileGroupDescriptor: PFileGroupDescriptorW);
  1654. var
  1655.   Size                  : integer;
  1656. begin
  1657.   Clear;
  1658.   if (AFileGroupDescriptor <> nil) then
  1659.   begin
  1660.     Size := SizeOf(UINT) + AFileGroupDescriptor^.cItems * SizeOf(TFileDescriptorW);
  1661.     GetMem(FFileGroupDescriptor, Size);
  1662.     Move(AFileGroupDescriptor^, FFileGroupDescriptor^, Size);
  1663.   end;
  1664. end;
  1665.  
  1666. function TFileGroupDescritorWClipboardFormat.GetSize: integer;
  1667. begin
  1668.   if (FFileGroupDescriptor <> nil) then
  1669.     Result := SizeOf(UINT) + FFileGroupDescriptor^.cItems * SizeOf(TFileDescriptorW)
  1670.   else
  1671.     Result := 0;
  1672. end;
  1673.  
  1674. function TFileGroupDescritorWClipboardFormat.ReadData(Value: pointer;
  1675.   Size: integer): boolean;
  1676. begin
  1677.   // Validate size against count
  1678.   Result :=
  1679.     (Size - SizeOf(UINT)) DIV SizeOf(TFileDescriptorW) = integer(PFileGroupDescriptor(Value)^.cItems);
  1680.   if (Result) then
  1681.     CopyFrom(PFileGroupDescriptorW(Value));
  1682. end;
  1683.  
  1684. function TFileGroupDescritorWClipboardFormat.WriteData(Value: pointer;
  1685.   Size: integer): boolean;
  1686. begin
  1687.   // Validate size against count
  1688.   Result := (FFileGroupDescriptor <> nil) and
  1689.     ((Size - SizeOf(UINT)) DIV SizeOf(TFileDescriptorW) = integer(FFileGroupDescriptor^.cItems));
  1690.  
  1691.   if (Result) then
  1692.     Move(FFileGroupDescriptor^, Value^, Size);
  1693. end;
  1694.  
  1695.  
  1696. ////////////////////////////////////////////////////////////////////////////////
  1697. //
  1698. //              TFileContentsClipboardFormat
  1699. //
  1700. ////////////////////////////////////////////////////////////////////////////////
  1701. var
  1702.   CF_FILECONTENTS: TClipFormat = 0;
  1703.  
  1704. constructor TFileContentsClipboardFormat.Create;
  1705. begin
  1706.   inherited Create;
  1707.   FFormatEtc.lindex := 0;
  1708. end;
  1709.  
  1710. function TFileContentsClipboardFormat.GetClipboardFormat: TClipFormat;
  1711. begin
  1712.   if (CF_FILECONTENTS = 0) then
  1713.     CF_FILECONTENTS := RegisterClipboardFormat(CFSTR_FILECONTENTS);
  1714.   Result := CF_FILECONTENTS;
  1715. end;
  1716.  
  1717.  
  1718. ////////////////////////////////////////////////////////////////////////////////
  1719. //
  1720. //              TFileContentsStreamClipboardFormat
  1721. //
  1722. ////////////////////////////////////////////////////////////////////////////////
  1723. constructor TFileContentsStreamClipboardFormat.Create;
  1724. begin
  1725.   CreateFormat(TYMED_ISTREAM);
  1726.   FStreams := TStreamList.Create;
  1727. end;
  1728.  
  1729. destructor TFileContentsStreamClipboardFormat.Destroy;
  1730. begin
  1731.   Clear;
  1732.   FStreams.Free;
  1733.   inherited Destroy;
  1734. end;
  1735.  
  1736. function TFileContentsStreamClipboardFormat.GetClipboardFormat: TClipFormat;
  1737. begin
  1738.   if (CF_FILECONTENTS = 0) then
  1739.     CF_FILECONTENTS := RegisterClipboardFormat(CFSTR_FILECONTENTS);
  1740.   Result := CF_FILECONTENTS;
  1741. end;
  1742.  
  1743. procedure TFileContentsStreamClipboardFormat.Clear;
  1744. begin
  1745.   FStreams.Clear;
  1746. end;
  1747.  
  1748. function TFileContentsStreamClipboardFormat.HasData: boolean;
  1749. begin
  1750.   Result := (FStreams.Count > 0);
  1751. end;
  1752.  
  1753. function TFileContentsStreamClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean;
  1754. begin
  1755.   Result := True;
  1756.   if (Dest is TDataStreamDataFormat) then
  1757.   begin
  1758.     TDataStreamDataFormat(Dest).Streams.Assign(Streams);
  1759.   end else
  1760.     Result := inherited AssignTo(Dest);
  1761. end;
  1762.  
  1763. {$IFOPT R+}
  1764.   {$DEFINE R_PLUS}
  1765.   {$RANGECHECKS OFF}
  1766. {$ENDIF}
  1767. function TFileContentsStreamClipboardFormat.GetData(DataObject: IDataObject): boolean;
  1768. var
  1769.   FGD: TFileGroupDescritorClipboardFormat;
  1770.   Count: integer;
  1771.   Medium: TStgMedium;
  1772.   Stream: IStream;
  1773.   Name: string;
  1774.   MemStream: TMemoryStream;
  1775.   StatStg: TStatStg;
  1776.   Size: longInt;
  1777.   Remaining: longInt;
  1778.   pChunk: PChar;
  1779. begin
  1780.   Result := False;
  1781.  
  1782.   Clear;
  1783.   FGD := TFileGroupDescritorClipboardFormat.Create;
  1784.   try
  1785.     if (FGD.GetData(DataObject)) then
  1786.     begin
  1787.       // Multiple objects, retrieve one at a time
  1788.       Count := FGD.FileGroupDescriptor^.cItems;
  1789.       FFormatEtc.lindex := 0;
  1790.     end else
  1791.     begin
  1792.       // Single object, retrieve "all" at once
  1793.       Count := 0;
  1794.       FFormatEtc.lindex := -1;
  1795.       Name := '';
  1796.     end;
  1797.     while (FFormatEtc.lindex < Count) do
  1798.     begin
  1799.       if (DataObject.GetData(FormatEtc, Medium) <> S_OK) then
  1800.         break;
  1801.       try
  1802.         inc(FFormatEtc.lindex);
  1803.         if (Medium.tymed <> TYMED_ISTREAM) then
  1804.           continue;
  1805.         Stream := IStream(Medium.stm);
  1806.         Stream.Stat(StatStg, STATFLAG_NONAME);
  1807.         MemStream := TMemoryStream.Create;
  1808.         try
  1809.           Remaining := StatStg.cbSize;
  1810.           MemStream.Size := Remaining;
  1811.           pChunk := MemStream.Memory;
  1812.           while (Remaining > 0) do
  1813.           begin
  1814.             if (Stream.Read(pChunk, Remaining, @Size) <> S_OK) or
  1815.               (Size = 0) then
  1816.               break;
  1817.             inc(pChunk, Size);
  1818.             dec(Remaining, Size);
  1819.           end;
  1820.  
  1821.           if (FFormatEtc.lindex > 0) then
  1822.             Name := FGD.FileGroupDescriptor^.fgd[FFormatEtc.lindex-1].cFileName;
  1823.           Streams.AddNamed(MemStream, Name);
  1824.         except
  1825.           MemStream.Free;
  1826.           raise;
  1827.         end;
  1828.         Stream := nil;
  1829.         Result := True;
  1830.       finally
  1831.         ReleaseStgMedium(Medium);
  1832.       end;
  1833.     end;
  1834.   finally
  1835.     FGD.Free;
  1836.   end;
  1837. end;
  1838. {$IFDEF R_PLUS}
  1839.   {$RANGECHECKS ON}
  1840.   {$UNDEF R_PLUS}
  1841. {$ENDIF}
  1842.  
  1843.  
  1844. ////////////////////////////////////////////////////////////////////////////////
  1845. //
  1846. //              TFileContentsStreamOnDemandClipboardFormat
  1847. //
  1848. ////////////////////////////////////////////////////////////////////////////////
  1849. constructor TFileContentsStreamOnDemandClipboardFormat.Create;
  1850. begin
  1851.   CreateFormat(TYMED_ISTREAM);
  1852. end;
  1853.  
  1854. destructor TFileContentsStreamOnDemandClipboardFormat.Destroy;
  1855. begin
  1856.   Clear;
  1857.   inherited Destroy;
  1858. end;
  1859.  
  1860. function TFileContentsStreamOnDemandClipboardFormat.GetClipboardFormat: TClipFormat;
  1861. begin
  1862.   if (CF_FILECONTENTS = 0) then
  1863.     CF_FILECONTENTS := RegisterClipboardFormat(CFSTR_FILECONTENTS);
  1864.   Result := CF_FILECONTENTS;
  1865. end;
  1866.  
  1867. procedure TFileContentsStreamOnDemandClipboardFormat.Clear;
  1868. begin
  1869.   FGotData := False;
  1870.   FDataRequested := False;
  1871. end;
  1872.  
  1873. function TFileContentsStreamOnDemandClipboardFormat.HasData: boolean;
  1874. begin
  1875.   Result := FGotData or FDataRequested;
  1876. end;
  1877.  
  1878. function TFileContentsStreamOnDemandClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean;
  1879. begin
  1880.   if (Dest is TVirtualFileStreamDataFormat) then
  1881.   begin
  1882.     Result := True
  1883.   end else
  1884.     Result := inherited AssignTo(Dest);
  1885. end;
  1886.  
  1887. function TFileContentsStreamOnDemandClipboardFormat.Assign(
  1888.   Source: TCustomDataFormat): boolean;
  1889. begin
  1890.   if (Source is TVirtualFileStreamDataFormat) then
  1891.   begin
  1892.     // Acknowledge that we can offer the requested data, but defer the actual
  1893.     // data transfer.
  1894.     FDataRequested := True;
  1895.     Result := True
  1896.   end else
  1897.     Result := inherited Assign(Source);
  1898. end;
  1899.  
  1900. function TFileContentsStreamOnDemandClipboardFormat.DoSetData(
  1901.   const FormatEtcIn: TFormatEtc; var AMedium: TStgMedium): boolean;
  1902. var
  1903.   Stream                : IStream;
  1904. begin
  1905.   if (Assigned(FOnGetStream)) and (FormatEtcIn.tymed and TYMED_ISTREAM <> 0) and
  1906.     (FormatEtcIn.lindex <> -1) then
  1907.   begin
  1908.     FOnGetStream(Self, FormatEtcIn.lindex, Stream);
  1909.  
  1910.     if (Stream <> nil) then
  1911.     begin
  1912.       IStream(AMedium.stm) := Stream;
  1913.       AMedium.tymed := TYMED_ISTREAM;
  1914.       Result := True;
  1915.     end else
  1916.       Result := False;
  1917.  
  1918.   end else
  1919.     Result := False;
  1920. end;
  1921.  
  1922. function TFileContentsStreamOnDemandClipboardFormat.GetData(DataObject: IDataObject): boolean;
  1923. begin
  1924.   // Flag that data has been offered to us, but defer the actual data transfer.
  1925.   FGotData := True;
  1926.   Result := True;
  1927. end;
  1928.  
  1929. function TFileContentsStreamOnDemandClipboardFormat.GetStream(Index: integer): IStream;
  1930. var
  1931.   Medium                : TStgMedium;
  1932. begin
  1933.   Result := nil;
  1934.   FFormatEtc.lindex := Index;
  1935.   // Get an IStream interface from the source.
  1936.   if ((DataFormat.Owner as TCustomDroptarget).DataObject.GetData(FormatEtc,
  1937.     Medium) = S_OK) and (Medium.tymed = TYMED_ISTREAM) then
  1938.     try
  1939.       Result := IStream(Medium.stm);
  1940.     finally
  1941.       ReleaseStgMedium(Medium);
  1942.     end;
  1943. end;
  1944.  
  1945.  
  1946. ////////////////////////////////////////////////////////////////////////////////
  1947. //
  1948. //              TFileContentsStorageClipboardFormat
  1949. //
  1950. ////////////////////////////////////////////////////////////////////////////////
  1951. constructor TFileContentsStorageClipboardFormat.Create;
  1952. begin
  1953.   CreateFormat(TYMED_ISTORAGE);
  1954.   FStorages := TStorageInterfaceList.Create;
  1955. end;
  1956.  
  1957. destructor TFileContentsStorageClipboardFormat.Destroy;
  1958. begin
  1959.   Clear;
  1960.   FStorages.Free;
  1961.   inherited Destroy;
  1962. end;
  1963.  
  1964. function TFileContentsStorageClipboardFormat.GetClipboardFormat: TClipFormat;
  1965. begin
  1966.   if (CF_FILECONTENTS = 0) then
  1967.     CF_FILECONTENTS := RegisterClipboardFormat(CFSTR_FILECONTENTS);
  1968.   Result := CF_FILECONTENTS;
  1969. end;
  1970.  
  1971. procedure TFileContentsStorageClipboardFormat.Clear;
  1972. begin
  1973.   FStorages.Clear;
  1974. end;
  1975.  
  1976. function TFileContentsStorageClipboardFormat.HasData: boolean;
  1977. begin
  1978.   Result := (FStorages.Count > 0);
  1979. end;
  1980.  
  1981. function TFileContentsStorageClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean;
  1982. begin
  1983. (*
  1984.   Result := True;
  1985.   if (Dest is TDataStreamDataFormat) then
  1986.   begin
  1987.     TDataStreamDataFormat(Dest).Streams.Assign(Streams);
  1988.   end else
  1989. *)
  1990.     Result := inherited AssignTo(Dest);
  1991. end;
  1992.  
  1993. {$IFOPT R+}
  1994.   {$DEFINE R_PLUS}
  1995.   {$RANGECHECKS OFF}
  1996. {$ENDIF}
  1997. function TFileContentsStorageClipboardFormat.GetData(DataObject: IDataObject): boolean;
  1998. var
  1999.   FGD                   : TFileGroupDescritorClipboardFormat;
  2000.   Count                 : integer;
  2001.   Medium                : TStgMedium;
  2002.   Storage               : IStorage;
  2003.   Name                  : string;
  2004. begin
  2005.   Result := False;
  2006.  
  2007.   Clear;
  2008.   FGD := TFileGroupDescritorClipboardFormat.Create;
  2009.   try
  2010.     if (FGD.GetData(DataObject)) then
  2011.     begin
  2012.       // Multiple objects, retrieve one at a time
  2013.       Count := FGD.FileGroupDescriptor^.cItems;
  2014.       FFormatEtc.lindex := 0;
  2015.     end else
  2016.     begin
  2017.       // Single object, retrieve "all" at once
  2018.       Count := 0;
  2019.       FFormatEtc.lindex := -1;
  2020.       Name := '';
  2021.     end;
  2022.     while (FFormatEtc.lindex < Count) do
  2023.     begin
  2024.       if (DataObject.GetData(FormatEtc, Medium) <> S_OK) then
  2025.         break;
  2026.       try
  2027.         inc(FFormatEtc.lindex);
  2028.         if (Medium.tymed <> TYMED_ISTORAGE) then
  2029.           continue;
  2030.         Storage := IStorage(Medium.stg);
  2031.         if (FFormatEtc.lindex > 0) then
  2032.           Name := FGD.FileGroupDescriptor^.fgd[FFormatEtc.lindex-1].cFileName;
  2033.         Storages.AddNamed(Storage, Name);
  2034.         Storage := nil;
  2035.         Result := True;
  2036.       finally
  2037.         ReleaseStgMedium(Medium);
  2038.       end;
  2039.     end;
  2040.   finally
  2041.     FGD.Free;
  2042.   end;
  2043. end;
  2044. {$IFDEF R_PLUS}
  2045.   {$RANGECHECKS ON}
  2046.   {$UNDEF R_PLUS}
  2047. {$ENDIF}
  2048.  
  2049.  
  2050. ////////////////////////////////////////////////////////////////////////////////
  2051. //
  2052. //              TPreferredDropEffectClipboardFormat
  2053. //
  2054. ////////////////////////////////////////////////////////////////////////////////
  2055. var
  2056.   CF_PREFERREDDROPEFFECT: TClipFormat = 0;
  2057.  
  2058. // GetClassClipboardFormat is used by TCustomDropTarget.GetPreferredDropEffect
  2059. class function TPreferredDropEffectClipboardFormat.GetClassClipboardFormat: TClipFormat;
  2060. begin
  2061.   if (CF_PREFERREDDROPEFFECT = 0) then
  2062.     CF_PREFERREDDROPEFFECT := RegisterClipboardFormat(CFSTR_PREFERREDDROPEFFECT);
  2063.   Result := CF_PREFERREDDROPEFFECT;
  2064. end;
  2065.  
  2066. function TPreferredDropEffectClipboardFormat.GetClipboardFormat: TClipFormat;
  2067. begin
  2068.   Result := GetClassClipboardFormat;
  2069. end;
  2070.  
  2071. function TPreferredDropEffectClipboardFormat.HasData: boolean;
  2072. begin
  2073.   Result := True; //(Value <> DROPEFFECT_NONE);
  2074. end;
  2075.  
  2076.  
  2077. ////////////////////////////////////////////////////////////////////////////////
  2078. //
  2079. //              TPerformedDropEffectClipboardFormat
  2080. //
  2081. ////////////////////////////////////////////////////////////////////////////////
  2082. var
  2083.   CF_PERFORMEDDROPEFFECT: TClipFormat = 0;
  2084.  
  2085. function TPerformedDropEffectClipboardFormat.GetClipboardFormat: TClipFormat;
  2086. begin
  2087.   if (CF_PERFORMEDDROPEFFECT = 0) then
  2088.     CF_PERFORMEDDROPEFFECT := RegisterClipboardFormat(CFSTR_PERFORMEDDROPEFFECT);
  2089.   Result := CF_PERFORMEDDROPEFFECT;
  2090. end;
  2091.  
  2092.  
  2093. ////////////////////////////////////////////////////////////////////////////////
  2094. //
  2095. //              TLogicalPerformedDropEffectClipboardFormat
  2096. //
  2097. ////////////////////////////////////////////////////////////////////////////////
  2098. var
  2099.   CF_LOGICALPERFORMEDDROPEFFECT: TClipFormat = 0;
  2100.  
  2101. function TLogicalPerformedDropEffectClipboardFormat.GetClipboardFormat: TClipFormat;
  2102. begin
  2103.   if (CF_LOGICALPERFORMEDDROPEFFECT = 0) then
  2104.     CF_LOGICALPERFORMEDDROPEFFECT := RegisterClipboardFormat('Logical Performed DropEffect'); // *** DO NOT LOCALIZE ***
  2105.   Result := CF_LOGICALPERFORMEDDROPEFFECT;
  2106. end;
  2107.  
  2108.  
  2109.  
  2110. ////////////////////////////////////////////////////////////////////////////////
  2111. //
  2112. //              TPasteSuccededClipboardFormat
  2113. //
  2114. ////////////////////////////////////////////////////////////////////////////////
  2115. var
  2116.   CF_PASTESUCCEEDED: TClipFormat = 0;
  2117.  
  2118. function TPasteSuccededClipboardFormat.GetClipboardFormat: TClipFormat;
  2119. begin
  2120.   if (CF_PASTESUCCEEDED = 0) then
  2121.     CF_PASTESUCCEEDED := RegisterClipboardFormat(CFSTR_PASTESUCCEEDED);
  2122.   Result := CF_PASTESUCCEEDED;
  2123. end;
  2124.  
  2125.  
  2126. ////////////////////////////////////////////////////////////////////////////////
  2127. //
  2128. //              TInShellDragLoopClipboardFormat
  2129. //
  2130. ////////////////////////////////////////////////////////////////////////////////
  2131. var
  2132.   CF_InDragLoop: TClipFormat = 0;
  2133.  
  2134. function TInShellDragLoopClipboardFormat.GetClipboardFormat: TClipFormat;
  2135. begin
  2136.   if (CF_InDragLoop = 0) then
  2137.     CF_InDragLoop := RegisterClipboardFormat(CFSTR_InDragLoop);
  2138.   Result := CF_InDragLoop;
  2139. end;
  2140.  
  2141.  
  2142. ////////////////////////////////////////////////////////////////////////////////
  2143. //
  2144. //              TTargetCLSIDClipboardFormat
  2145. //
  2146. ////////////////////////////////////////////////////////////////////////////////
  2147. procedure TTargetCLSIDClipboardFormat.Clear;
  2148. begin
  2149.   FCLSID := GUID_NULL;
  2150. end;
  2151.  
  2152. var
  2153.   CF_TargetCLSID: TClipFormat = 0;
  2154.  
  2155. function TTargetCLSIDClipboardFormat.GetClipboardFormat: TClipFormat;
  2156. begin
  2157.   if (CF_TargetCLSID = 0) then
  2158.     CF_TargetCLSID := RegisterClipboardFormat('TargetCLSID'); // *** DO NOT LOCALIZE ***
  2159.   Result := CF_TargetCLSID;
  2160. end;
  2161.  
  2162. function TTargetCLSIDClipboardFormat.GetSize: integer;
  2163. begin
  2164.   Result := SizeOf(TCLSID);
  2165. end;
  2166.  
  2167. function TTargetCLSIDClipboardFormat.HasData: boolean;
  2168. begin
  2169.   Result := not IsEqualCLSID(FCLSID, GUID_NULL);
  2170. end;
  2171.  
  2172. function TTargetCLSIDClipboardFormat.ReadData(Value: pointer;
  2173.   Size: integer): boolean;
  2174. begin
  2175.   // Validate size.
  2176.   Result := (Size = SizeOf(TCLSID));
  2177.   if (Result) then
  2178.     FCLSID := PCLSID(Value)^;
  2179. end;
  2180.  
  2181. function TTargetCLSIDClipboardFormat.WriteData(Value: pointer;
  2182.   Size: integer): boolean;
  2183. begin
  2184.   // Validate size.
  2185.   Result := (Size = SizeOf(TCLSID));
  2186.   if (Result) then
  2187.     PCLSID(Value)^ := FCLSID;
  2188. end;
  2189.  
  2190. ////////////////////////////////////////////////////////////////////////////////
  2191. ////////////////////////////////////////////////////////////////////////////////
  2192. ////////////////////////////////////////////////////////////////////////////////
  2193.  
  2194.  
  2195. ////////////////////////////////////////////////////////////////////////////////
  2196. //
  2197. //              TTextDataFormat
  2198. //
  2199. ////////////////////////////////////////////////////////////////////////////////
  2200. function TTextDataFormat.Assign(Source: TClipboardFormat): boolean;
  2201. begin
  2202.   Result := True;
  2203.  
  2204.   if (Source is TTextClipboardFormat) then
  2205.     FText := TTextClipboardFormat(Source).Text
  2206.   else if (Source is TFileContentsClipboardFormat) then
  2207.     FText := TFileContentsClipboardFormat(Source).Data
  2208.   else
  2209.     Result := inherited Assign(Source);
  2210. end;
  2211.  
  2212. function TTextDataFormat.AssignTo(Dest: TClipboardFormat): boolean;
  2213. var
  2214.   FGD: TFileGroupDescriptor;
  2215.   FGDW: TFileGroupDescriptorW;
  2216. resourcestring
  2217.   // Name of the text scrap file.
  2218.   sTextScrap = 'Text scrap.txt';
  2219. begin
  2220.   Result := True;
  2221.  
  2222.   if (Dest is TTextClipboardFormat) then
  2223.     TTextClipboardFormat(Dest).Text := FText
  2224.   else if (Dest is TFileContentsClipboardFormat) then
  2225.     TFileContentsClipboardFormat(Dest).Data := FText
  2226.   else if (Dest is TFileGroupDescritorClipboardFormat) then
  2227.   begin
  2228.     FillChar(FGD, SizeOf(FGD), 0);
  2229.     FGD.cItems := 1;
  2230.     StrPLCopy(FGD.fgd[0].cFileName, sTextScrap, SizeOf(FGD.fgd[0].cFileName));
  2231.     TFileGroupDescritorClipboardFormat(Dest).CopyFrom(@FGD);
  2232.   end else
  2233.   if (Dest is TFileGroupDescritorWClipboardFormat) then
  2234.   begin
  2235.     FillChar(FGDW, SizeOf(FGDW), 0);
  2236.     FGDW.cItems := 1;
  2237.     StringToWideChar(sTextScrap, PWideChar(@(FGDW.fgd[0].cFileName)), MAX_PATH);
  2238.     TFileGroupDescritorWClipboardFormat(Dest).CopyFrom(@FGDW);
  2239.   end else
  2240.     Result := inherited AssignTo(Dest);
  2241. end;
  2242.  
  2243. procedure TTextDataFormat.Clear;
  2244. begin
  2245.   Changing;
  2246.   FText := '';
  2247. end;
  2248.  
  2249. procedure TTextDataFormat.SetText(const Value: string);
  2250. begin
  2251.   Changing;
  2252.   FText := Value;
  2253. end;
  2254.  
  2255. function TTextDataFormat.HasData: boolean;
  2256. begin
  2257.   Result := (FText <> '');
  2258. end;
  2259.  
  2260. function TTextDataFormat.NeedsData: boolean;
  2261. begin
  2262.   Result := (FText = '');
  2263. end;
  2264.  
  2265.  
  2266. ////////////////////////////////////////////////////////////////////////////////
  2267. //
  2268. //              TDataStreamDataFormat
  2269. //
  2270. ////////////////////////////////////////////////////////////////////////////////
  2271. constructor TDataStreamDataFormat.Create(AOwner: TDragDropComponent);
  2272. begin
  2273.   inherited Create(AOwner);
  2274.   FStreams := TStreamList.Create;
  2275.   FStreams.OnChanging := DoOnChanging;
  2276. end;
  2277.  
  2278. destructor TDataStreamDataFormat.Destroy;
  2279. begin
  2280.   Clear;
  2281.   FStreams.Free;
  2282.   inherited Destroy;
  2283. end;
  2284.  
  2285. procedure TDataStreamDataFormat.Clear;
  2286. begin
  2287.   Changing;
  2288.   FStreams.Clear;
  2289. end;
  2290.  
  2291. function TDataStreamDataFormat.HasData: boolean;
  2292. begin
  2293.   Result := (Streams.Count > 0);
  2294. end;
  2295.  
  2296. function TDataStreamDataFormat.NeedsData: boolean;
  2297. begin
  2298.   Result := (Streams.Count = 0);
  2299. end;
  2300.  
  2301.  
  2302. ////////////////////////////////////////////////////////////////////////////////
  2303. //
  2304. //              TFileDescriptorToFilenameStrings
  2305. //
  2306. ////////////////////////////////////////////////////////////////////////////////
  2307. // Used internally to convert between FileDescriptors and filenames on-demand.
  2308. ////////////////////////////////////////////////////////////////////////////////
  2309. type
  2310.   TFileDescriptorToFilenameStrings = class(TStrings)
  2311.   private
  2312.     FFileDescriptors: TMemoryList;
  2313.   protected
  2314.     function Get(Index: Integer): string; override;
  2315.     function GetCount: Integer; override;
  2316.   public
  2317.     constructor Create(AFileDescriptors: TMemoryList);
  2318.     procedure Clear; override;
  2319.     procedure Delete(Index: Integer); override;
  2320.     procedure Insert(Index: Integer; const S: string); override;
  2321.     procedure Assign(Source: TPersistent); override;
  2322.   end;
  2323.  
  2324. constructor TFileDescriptorToFilenameStrings.Create(AFileDescriptors: TMemoryList);
  2325. begin
  2326.   inherited Create;
  2327.   FFileDescriptors := AFileDescriptors;
  2328. end;
  2329.  
  2330. function TFileDescriptorToFilenameStrings.Get(Index: Integer): string;
  2331. begin
  2332.   Result := PFileDescriptor(FFileDescriptors[Index]).cFileName;
  2333. end;
  2334.  
  2335. function TFileDescriptorToFilenameStrings.GetCount: Integer;
  2336. begin
  2337.   Result := FFileDescriptors.Count;
  2338. end;
  2339.  
  2340. procedure TFileDescriptorToFilenameStrings.Assign(Source: TPersistent);
  2341. var
  2342.   i: integer;
  2343. begin
  2344.   if Source is TStrings then
  2345.   begin
  2346.     BeginUpdate;
  2347.     try
  2348.       FFileDescriptors.Clear;
  2349.       for i := 0 to TStrings(Source).Count-1 do
  2350.         Add(TStrings(Source)[i]);
  2351.     finally
  2352.       EndUpdate;
  2353.     end;
  2354.   end else
  2355.     inherited Assign(Source);
  2356. end;
  2357.  
  2358. procedure TFileDescriptorToFilenameStrings.Clear;
  2359. begin
  2360.   FFileDescriptors.Clear;
  2361. end;
  2362.  
  2363. procedure TFileDescriptorToFilenameStrings.Delete(Index: Integer);
  2364. begin
  2365.   FFileDescriptors.Delete(Index);
  2366. end;
  2367.  
  2368. procedure TFileDescriptorToFilenameStrings.Insert(Index: Integer; const S: string);
  2369. var
  2370.   FD: PFileDescriptor;
  2371. begin
  2372.   if (Index = FFileDescriptors.Count) then
  2373.   begin
  2374.     GetMem(FD, SizeOf(TFileDescriptor));
  2375.     try
  2376.       FillChar(FD^, SizeOf(TFileDescriptor), 0);
  2377.       StrPLCopy(FD.cFileName, S, SizeOf(FD.cFileName));
  2378.       FFileDescriptors.Add(FD);
  2379.     except
  2380.       FreeMem(FD);
  2381.       raise;
  2382.     end;
  2383.   end;
  2384. end;
  2385.  
  2386. ////////////////////////////////////////////////////////////////////////////////
  2387. //
  2388. //              TVirtualFileStreamDataFormat
  2389. //
  2390. ////////////////////////////////////////////////////////////////////////////////
  2391. constructor TVirtualFileStreamDataFormat.Create(AOwner: TDragDropComponent);
  2392. begin
  2393.   inherited Create(AOwner);
  2394.   FFileDescriptors := TMemoryList.Create;
  2395.   FFileNames := TFileDescriptorToFilenameStrings.Create(FFileDescriptors);
  2396.  
  2397.   // Add the "file group descriptor" and "file contents" clipboard formats to
  2398.   // the data format's list of compatible formats.
  2399.   // Note: This is normally done via TCustomDataFormat.RegisterCompatibleFormat,
  2400.   // but since this data format and the clipboard format class are specialized
  2401.   // to be used with each other, it is just as easy for us to add the formats
  2402.   // manually.
  2403.   FFileContentsClipboardFormat := TFileContentsStreamOnDemandClipboardFormat.Create;
  2404.   CompatibleFormats.Add(FFileContentsClipboardFormat);
  2405.  
  2406.   FFileGroupDescritorClipboardFormat := TFileGroupDescritorClipboardFormat.Create;
  2407.  
  2408.   // Normaly TFileGroupDescritorClipboardFormat supports both HGlobal and
  2409.   // IStream storage medium transfers, but for this demo we only use IStream.
  2410. //  FFileGroupDescritorClipboardFormat.FormatEtc.tymed := TYMED_ISTREAM;
  2411.  
  2412.   CompatibleFormats.Add(FFileGroupDescritorClipboardFormat);
  2413. end;
  2414.  
  2415. destructor TVirtualFileStreamDataFormat.Destroy;
  2416. begin
  2417.   FFileDescriptors.Free;
  2418.   FFileNames.Free;
  2419.   inherited Destroy;
  2420. end;
  2421.  
  2422. procedure TVirtualFileStreamDataFormat.SetFileNames(const Value: TStrings);
  2423. begin
  2424.   FFileNames.Assign(Value);
  2425. end;
  2426.  
  2427. {$IFOPT R+}
  2428.   {$DEFINE R_PLUS}
  2429.   {$RANGECHECKS OFF}
  2430. {$ENDIF}
  2431. function TVirtualFileStreamDataFormat.Assign(Source: TClipboardFormat): boolean;
  2432. var
  2433.   i: integer;
  2434.   FD: PFileDescriptor;
  2435. begin
  2436.   Result := True;
  2437.  
  2438.   (*
  2439.   ** TFileContentsStreamOnDemandClipboardFormat
  2440.   *)
  2441.   if (Source is TFileContentsStreamOnDemandClipboardFormat) then
  2442.   begin
  2443.     FHasContents := TFileContentsStreamOnDemandClipboardFormat(Source).HasData;
  2444.   end else
  2445.   (*
  2446.   ** TFileGroupDescritorClipboardFormat
  2447.   *)
  2448.   if (Source is TFileGroupDescritorClipboardFormat) then
  2449.   begin
  2450.     FFileDescriptors.Clear;
  2451.     for i := 0 to TFileGroupDescritorClipboardFormat(Source).FileGroupDescriptor^.cItems-1 do
  2452.     begin
  2453.       GetMem(FD, SizeOf(TFileDescriptor));
  2454.       try
  2455.         Move(TFileGroupDescritorClipboardFormat(Source).FileGroupDescriptor^.fgd[i],
  2456.           FD^, SizeOf(TFileDescriptor));
  2457.         FFileDescriptors.Add(FD);
  2458.       except
  2459.         FreeMem(FD);
  2460.         raise;
  2461.       end;
  2462.     end;
  2463.   end else
  2464.   (*
  2465.   ** None of the above...
  2466.   *)
  2467.     Result := inherited Assign(Source);
  2468. end;
  2469. {$IFDEF R_PLUS}
  2470.   {$RANGECHECKS ON}
  2471.   {$UNDEF R_PLUS}
  2472. {$ENDIF}
  2473.  
  2474. {$IFOPT R+}
  2475.   {$DEFINE R_PLUS}
  2476.   {$RANGECHECKS OFF}
  2477. {$ENDIF}
  2478. function TVirtualFileStreamDataFormat.AssignTo(Dest: TClipboardFormat): boolean;
  2479. var
  2480.   FGD: PFileGroupDescriptor;
  2481.   i: integer;
  2482. begin
  2483.   (*
  2484.   ** TFileContentsStreamOnDemandClipboardFormat
  2485.   *)
  2486.   if (Dest is TFileContentsStreamOnDemandClipboardFormat) then
  2487.   begin
  2488.     // Let the clipboard format handle the transfer.
  2489.     // No data is actually transferred, but TFileContentsStreamOnDemandClipboardFormat
  2490.     // needs to set a flag when data is requested.
  2491.     Result := Dest.Assign(Self);
  2492.   end else
  2493.   (*
  2494.   ** TFileGroupDescritorClipboardFormat
  2495.   *)
  2496.   if (Dest is TFileGroupDescritorClipboardFormat) then
  2497.   begin
  2498.     if (FFileDescriptors.Count > 0) then
  2499.     begin
  2500.       GetMem(FGD, SizeOf(UINT) + FFileDescriptors.Count * SizeOf(TFileDescriptor));
  2501.       try
  2502.         FGD.cItems := FFileDescriptors.Count;
  2503.         for i := 0 to FFileDescriptors.Count-1 do
  2504.           Move(FFileDescriptors[i]^, FGD.fgd[i], SizeOf(TFileDescriptor));
  2505.  
  2506.         TFileGroupDescritorClipboardFormat(Dest).CopyFrom(FGD);
  2507.       finally
  2508.         FreeMem(FGD);
  2509.       end;
  2510.       Result := True;
  2511.     end else
  2512.       Result := False;
  2513.   end else
  2514.   (*
  2515.   ** None of the above...
  2516.   *)
  2517.     Result := inherited AssignTo(Dest);
  2518. end;
  2519. {$IFDEF R_PLUS}
  2520.   {$RANGECHECKS ON}
  2521.   {$UNDEF R_PLUS}
  2522. {$ENDIF}
  2523.  
  2524. procedure TVirtualFileStreamDataFormat.Clear;
  2525. begin
  2526.   FFileDescriptors.Clear;
  2527.   FHasContents := False;
  2528. end;
  2529.  
  2530. function TVirtualFileStreamDataFormat.HasData: boolean;
  2531. begin
  2532.   Result := (FFileDescriptors.Count > 0) and
  2533.     ((FHasContents) or Assigned(FFileContentsClipboardFormat.OnGetStream));
  2534. end;
  2535.  
  2536. function TVirtualFileStreamDataFormat.NeedsData: boolean;
  2537. begin
  2538.   Result := (FFileDescriptors.Count = 0) or (not FHasContents);
  2539. end;
  2540.  
  2541. function TVirtualFileStreamDataFormat.GetOnGetStream: TOnGetStreamEvent;
  2542. begin
  2543.   Result := FFileContentsClipboardFormat.OnGetStream;
  2544. end;
  2545.  
  2546. procedure TVirtualFileStreamDataFormat.SetOnGetStream(const Value: TOnGetStreamEvent);
  2547. begin
  2548.   FFileContentsClipboardFormat.OnGetStream := Value;
  2549. end;
  2550.  
  2551.  
  2552. ////////////////////////////////////////////////////////////////////////////////
  2553. //
  2554. //              TFeedbackDataFormat
  2555. //
  2556. ////////////////////////////////////////////////////////////////////////////////
  2557. function TFeedbackDataFormat.Assign(Source: TClipboardFormat): boolean;
  2558. begin
  2559.   Result := True;
  2560.  
  2561.   if (Source is TPreferredDropEffectClipboardFormat) then
  2562.     FPreferredDropEffect := TPreferredDropEffectClipboardFormat(Source).Value
  2563.  
  2564.   else if (Source is TPerformedDropEffectClipboardFormat) then
  2565.     FPerformedDropEffect := TPerformedDropEffectClipboardFormat(Source).Value
  2566.  
  2567.   else if (Source is TLogicalPerformedDropEffectClipboardFormat) then
  2568.     FLogicalPerformedDropEffect := TLogicalPerformedDropEffectClipboardFormat(Source).Value
  2569.  
  2570.   else if (Source is TPasteSuccededClipboardFormat) then
  2571.     FPasteSucceded := TPasteSuccededClipboardFormat(Source).Value
  2572.  
  2573.   else if (Source is TTargetCLSIDClipboardFormat) then
  2574.     FTargetCLSID := TTargetCLSIDClipboardFormat(Source).CLSID
  2575.  
  2576.   else if (Source is TInShellDragLoopClipboardFormat) then
  2577.   begin
  2578.     FInShellDragLoop := TInShellDragLoopClipboardFormat(Source).InShellDragLoop;
  2579.     FGotInShellDragLoop := True;
  2580.   end else
  2581.     Result := inherited Assign(Source);
  2582. end;
  2583.  
  2584. function TFeedbackDataFormat.AssignTo(Dest: TClipboardFormat): boolean;
  2585. begin
  2586.   Result := True;
  2587.  
  2588.   if (Dest is TPreferredDropEffectClipboardFormat) then
  2589.     TPreferredDropEffectClipboardFormat(Dest).Value := FPreferredDropEffect
  2590.  
  2591.   else if (Dest is TPerformedDropEffectClipboardFormat) then
  2592.     TPerformedDropEffectClipboardFormat(Dest).Value := FPerformedDropEffect
  2593.  
  2594.   else if (Dest is TLogicalPerformedDropEffectClipboardFormat) then
  2595.     TLogicalPerformedDropEffectClipboardFormat(Dest).Value := FLogicalPerformedDropEffect
  2596.  
  2597.   else if (Dest is TPasteSuccededClipboardFormat) then
  2598.     TPasteSuccededClipboardFormat(Dest).Value := FPasteSucceded
  2599.  
  2600.   else if (Dest is TTargetCLSIDClipboardFormat) then
  2601.     TTargetCLSIDClipboardFormat(Dest).CLSID := FTargetCLSID
  2602.  
  2603.   else if (Dest is TInShellDragLoopClipboardFormat) then
  2604.     TInShellDragLoopClipboardFormat(Dest).InShellDragLoop := FInShellDragLoop
  2605.  
  2606.   else
  2607.     Result := inherited AssignTo(Dest);
  2608. end;
  2609.  
  2610. procedure TFeedbackDataFormat.Clear;
  2611. begin
  2612.   Changing;
  2613.   FPreferredDropEffect := DROPEFFECT_NONE;
  2614.   FPerformedDropEffect := DROPEFFECT_NONE;
  2615.   FInShellDragLoop := False;
  2616.   FGotInShellDragLoop := False;
  2617. end;
  2618.  
  2619. procedure TFeedbackDataFormat.SetInShellDragLoop(const Value: boolean);
  2620. begin
  2621.   Changing;
  2622.   FInShellDragLoop := Value;
  2623. end;
  2624.  
  2625. procedure TFeedbackDataFormat.SetPasteSucceded(const Value: longInt);
  2626. begin
  2627.   Changing;
  2628.   FPasteSucceded := Value;
  2629. end;
  2630.  
  2631. procedure TFeedbackDataFormat.SetPerformedDropEffect(
  2632.   const Value: longInt);
  2633. begin
  2634.   Changing;
  2635.   FPerformedDropEffect := Value;
  2636. end;
  2637.  
  2638. procedure TFeedbackDataFormat.SetLogicalPerformedDropEffect(
  2639.   const Value: longInt);
  2640. begin
  2641.   Changing;
  2642.   FLogicalPerformedDropEffect := Value;
  2643. end;
  2644.  
  2645. procedure TFeedbackDataFormat.SetPreferredDropEffect(
  2646.   const Value: longInt);
  2647. begin
  2648.   Changing;
  2649.   FPreferredDropEffect := Value;
  2650. end;
  2651.  
  2652. procedure TFeedbackDataFormat.SetTargetCLSID(const Value: TCLSID);
  2653. begin
  2654.   Changing;
  2655.   FTargetCLSID := Value;
  2656. end;
  2657.  
  2658. function TFeedbackDataFormat.HasData: boolean;
  2659. begin
  2660.   Result := (FPreferredDropEffect <> DROPEFFECT_NONE) or
  2661.     (FPerformedDropEffect <> DROPEFFECT_NONE) or
  2662.     (FPasteSucceded <> DROPEFFECT_NONE) or
  2663.     (FGotInShellDragLoop);
  2664. end;
  2665.  
  2666. function TFeedbackDataFormat.NeedsData: boolean;
  2667. begin
  2668.   Result := (FPreferredDropEffect = DROPEFFECT_NONE) or
  2669.     (FPerformedDropEffect = DROPEFFECT_NONE) or
  2670.     (FPasteSucceded = DROPEFFECT_NONE) or
  2671.     (not FGotInShellDragLoop);
  2672. end;
  2673.  
  2674.  
  2675. ////////////////////////////////////////////////////////////////////////////////
  2676. //
  2677. //              TGenericClipboardFormat
  2678. //
  2679. ////////////////////////////////////////////////////////////////////////////////
  2680. procedure TGenericClipboardFormat.SetClipboardFormatName(const Value: string);
  2681. begin
  2682.   FFormat := Value;
  2683.   if (FFormat <> '') then
  2684.     ClipboardFormat := RegisterClipboardFormat(PChar(FFormat));
  2685. end;
  2686.  
  2687. function TGenericClipboardFormat.GetClipboardFormat: TClipFormat;
  2688. begin
  2689.   if (FFormatEtc.cfFormat = 0) and (FFormat <> '') then
  2690.     FFormatEtc.cfFormat := RegisterClipboardFormat(PChar(FFormat));
  2691.   Result := FFormatEtc.cfFormat;
  2692. end;
  2693.  
  2694. function TGenericClipboardFormat.GetClipboardFormatName: string;
  2695. begin
  2696.   Result := FFormat;
  2697. end;
  2698.  
  2699. function TGenericClipboardFormat.Assign(Source: TCustomDataFormat): boolean;
  2700. begin
  2701.   if (Source is TGenericDataFormat) then
  2702.   begin
  2703.     Data := TGenericDataFormat(Source).Data;
  2704.     Result := True;
  2705.   end else
  2706.     Result := inherited Assign(Source);
  2707. end;
  2708.  
  2709. function TGenericClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean;
  2710. begin
  2711.   if (Dest is TGenericDataFormat) then
  2712.   begin
  2713.     TGenericDataFormat(Dest).Data := Data;
  2714.     Result := True;
  2715.   end else
  2716.     Result := inherited AssignTo(Dest);
  2717. end;
  2718.  
  2719. ////////////////////////////////////////////////////////////////////////////////
  2720. //
  2721. //              TGenericDataFormat
  2722. //
  2723. ////////////////////////////////////////////////////////////////////////////////
  2724. procedure TGenericDataFormat.AddFormat(const AFormat: string);
  2725. var
  2726.   ClipboardFormat: TGenericClipboardFormat;
  2727. begin
  2728.   ClipboardFormat := TGenericClipboardFormat.Create;
  2729.   ClipboardFormat.ClipboardFormatName := AFormat;
  2730.   ClipboardFormat.DataDirections := [ddRead];
  2731.   CompatibleFormats.Add(ClipboardFormat);
  2732. end;
  2733.  
  2734. procedure TGenericDataFormat.Clear;
  2735. begin
  2736.   Changing;
  2737.   FData := '';
  2738. end;
  2739.  
  2740. function TGenericDataFormat.HasData: boolean;
  2741. begin
  2742.   Result := (FData <> '');
  2743. end;
  2744.  
  2745. function TGenericDataFormat.NeedsData: boolean;
  2746. begin
  2747.   Result := (FData = '');
  2748. end;
  2749.  
  2750. procedure TGenericDataFormat.DoSetData(const Value: string);
  2751. begin
  2752.   Changing;
  2753.   FData := Value;
  2754. end;
  2755.  
  2756. procedure TGenericDataFormat.SetDataHere(const AData; ASize: integer);
  2757. begin
  2758.   Changing;
  2759.   SetLength(FData, ASize);
  2760.   Move(AData, PChar(FData)^, ASize);
  2761. end;
  2762.  
  2763. function TGenericDataFormat.GetSize: integer;
  2764. begin
  2765.   Result := length(FData);
  2766. end;
  2767.  
  2768. function TGenericDataFormat.GetDataHere(var AData; ASize: integer): integer;
  2769. begin
  2770.   Result := Size;
  2771.   if (ASize < Result) then
  2772.     Result := ASize;
  2773.   Move(PChar(FData)^, AData, Result);
  2774. end;
  2775.  
  2776.  
  2777. ////////////////////////////////////////////////////////////////////////////////
  2778. //
  2779. //              Initialization/Finalization
  2780. //
  2781. ////////////////////////////////////////////////////////////////////////////////
  2782.  
  2783. initialization
  2784.   // Data format registration
  2785.   TTextDataFormat.RegisterDataFormat;
  2786.   TDataStreamDataFormat.RegisterDataFormat;
  2787.   TVirtualFileStreamDataFormat.RegisterDataFormat;
  2788.  
  2789.   // Clipboard format registration
  2790.   TTextDataFormat.RegisterCompatibleFormat(TTextClipboardFormat, 0, csSourceTarget, [ddRead]);
  2791.   TTextDataFormat.RegisterCompatibleFormat(TFileContentsClipboardFormat, 1, csSourceTarget, [ddRead]);
  2792.   TTextDataFormat.RegisterCompatibleFormat(TFileGroupDescritorClipboardFormat, 1, [csSource], [ddRead]);
  2793.   TTextDataFormat.RegisterCompatibleFormat(TFileGroupDescritorWClipboardFormat, 1, [csSource], [ddRead]);
  2794.   TFeedbackDataFormat.RegisterCompatibleFormat(TPreferredDropEffectClipboardFormat, 0, csSourceTarget, [ddRead]);
  2795.   TFeedbackDataFormat.RegisterCompatibleFormat(TPerformedDropEffectClipboardFormat, 0, csSourceTarget, [ddWrite]);
  2796.   TFeedbackDataFormat.RegisterCompatibleFormat(TPasteSuccededClipboardFormat, 0, csSourceTarget, [ddWrite]);
  2797.   TFeedbackDataFormat.RegisterCompatibleFormat(TInShellDragLoopClipboardFormat, 0, csSourceTarget, [ddRead]);
  2798.   TFeedbackDataFormat.RegisterCompatibleFormat(TTargetCLSIDClipboardFormat, 0, csSourceTarget, [ddWrite]);
  2799.   TFeedbackDataFormat.RegisterCompatibleFormat(TLogicalPerformedDropEffectClipboardFormat, 0, csSourceTarget, [ddWrite]);
  2800.   TDataStreamDataFormat.RegisterCompatibleFormat(TFileContentsStreamClipboardFormat, 0, [csTarget], [ddRead]);
  2801.  
  2802. finalization
  2803.   TTextDataFormat.UnregisterDataFormat;
  2804.   TDataStreamDataFormat.UnregisterDataFormat;
  2805.   TFeedbackDataFormat.UnregisterDataFormat;
  2806.   TVirtualFileStreamDataFormat.UnregisterDataFormat;
  2807.  
  2808.   TTextClipboardFormat.UnregisterClipboardFormat;
  2809.   TFileGroupDescritorClipboardFormat.UnregisterClipboardFormat;
  2810.   TFileGroupDescritorWClipboardFormat.UnregisterClipboardFormat;
  2811.   TFileContentsClipboardFormat.UnregisterClipboardFormat;
  2812.   TFileContentsStreamClipboardFormat.UnregisterClipboardFormat;
  2813.   TPreferredDropEffectClipboardFormat.UnregisterClipboardFormat;
  2814.   TPerformedDropEffectClipboardFormat.UnregisterClipboardFormat;
  2815.   TPasteSuccededClipboardFormat.UnregisterClipboardFormat;
  2816.   TInShellDragLoopClipboardFormat.UnregisterClipboardFormat;
  2817.   TTargetCLSIDClipboardFormat.UnregisterClipboardFormat;
  2818.   TLogicalPerformedDropEffectClipboardFormat.UnregisterClipboardFormat;
  2819.  
  2820. end.
  2821.  
  2822.  
  2823.