| /trunk/VCL_DRAGDROP/DragDrop.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DragDrop.inc |
|---|
| 0,0 → 1,135 |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite |
| // Module: DragDrop.inc |
| // Description: This include file contains common defines used by the |
| // library. |
| // Authors: Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2000 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| // ----------------------------------------------------------------------------- |
| // Detect compiler version |
| // ----------------------------------------------------------------------------- |
| // Delphi 1.x |
| {$IFDEF VER80} |
| {$DEFINE VER8_PLUS} |
| {$DEFINE VER_OK} |
| {$ENDIF} |
| // Delphi 2.x |
| {$IFDEF VER90} |
| {$DEFINE VER9x} |
| {$DEFINE VER9_PLUS} |
| {$DEFINE VER_OK} |
| {$ENDIF} |
| // C++ Builder 1.x |
| {$IFDEF VER93} |
| {$DEFINE VER9x} |
| {$DEFINE VER93_PLUS} |
| {$DEFINE VER_OK} |
| {$ENDIF} |
| // Delphi 3.x |
| {$IFDEF VER100} |
| {$DEFINE VER10_PLUS} |
| {$DEFINE VER_OK} |
| {$ENDIF} |
| // C++ Builder 3.x |
| {$IFDEF VER110} |
| {$DEFINE VER11_PLUS} |
| {$DEFINE VER_OK} |
| {$ENDIF} |
| // Delphi 4.x |
| {$IFDEF VER120} |
| {$DEFINE VER12_PLUS} |
| {$DEFINE VER_OK} |
| {$ENDIF} |
| // C++ Builder 4.x |
| {$IFDEF VER125} |
| {$DEFINE VER125_PLUS} |
| {$DEFINE VER_OK} |
| {$ENDIF} |
| // Delphi 5.x |
| {$IFDEF VER130} |
| {$DEFINE VER13_PLUS} |
| {$DEFINE VER_OK} |
| {$ENDIF} |
| // C++ Builder 5.x - Not verified! |
| {$IFDEF VER130} |
| {$IFDEF BCB} |
| {$DEFINE VER135_PLUS} |
| {$DEFINE VER_OK} |
| {$ENDIF} |
| {$ENDIF} |
| // Delphi 6.x |
| {$IFDEF VER140} |
| {$DEFINE VER14_PLUS} |
| {$DEFINE VER_OK} |
| {$ENDIF} |
| // Unknown compiler version - assume D6 compatible |
| {$IFNDEF VER_OK} |
| {$DEFINE VER14_PLUS} |
| {$ELSE} |
| {$UNDEF VER_OK} |
| {$ENDIF} |
| {$IFDEF VER14_PLUS} |
| {$DEFINE VER135_PLUS} |
| {$ENDIF} |
| {$IFDEF VER135_PLUS} |
| {$DEFINE VER13_PLUS} |
| {$ENDIF} |
| {$IFDEF VER13_PLUS} |
| {$DEFINE VER125_PLUS} |
| {$ENDIF} |
| {$IFDEF VER125_PLUS} |
| {$DEFINE VER12_PLUS} |
| {$ENDIF} |
| {$IFDEF VER12_PLUS} |
| {$DEFINE VER11_PLUS} |
| {$ENDIF} |
| {$IFDEF VER11_PLUS} |
| {$DEFINE VER10_PLUS} |
| {$ENDIF} |
| {$IFDEF VER10_PLUS} |
| {$DEFINE VER93_PLUS} |
| {$ENDIF} |
| {$IFDEF VER93_PLUS} |
| {$DEFINE VER9_PLUS} |
| {$ENDIF} |
| {$IFDEF VER9_PLUS} |
| {$DEFINE VER8_PLUS} |
| {$ENDIF} |
| // ----------------------------------------------------------------------------- |
| // Required compiler directives |
| // ----------------------------------------------------------------------------- |
| {$BOOLEVAL OFF} // Short circuit boolean evaluation. |
| {$EXTENDEDSYNTAX ON} // Enable Delphi Pascal extensions. |
| {$LONGSTRINGS ON} // String = AnsiString. |
| {$ALIGN ON} // Aligned data. Required by COM. |
| {$ifdef BCB} |
| {$ObjExportAll ON} // Required for C++ Builder |
| {$endif} |
| // The following are not realy nescessary, but they are good practice. |
| {$TYPEDADDRESS ON} // @ operator returns typed pointer. |
| {$WRITEABLECONST OFF} // Typed consts are R/O. |
| // Disable platform warnings. This library is only supported on Windows. |
| {$ifdef VER14_PLUS} |
| {$WARN SYMBOL_PLATFORM OFF} |
| {$endif} |
| /trunk/VCL_DRAGDROP/DragDrop.pas |
|---|
| 0,0 → 1,1958 |
| unit DragDrop; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite |
| // Module: DragDrop |
| // Description: Implements base classes and utility functions. |
| // Version: 4.0 |
| // Date: 18-MAY-2001 |
| // Target: Win32, Delphi 5-6 |
| // Authors: Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2001 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| // TODO -oanme -cPortability : Replace all public use of HWND with THandle. BCB's HWND <> Delphi's HWND. |
| {$include DragDrop.inc} |
| interface |
| uses |
| Classes, |
| Windows, |
| ActiveX; |
| {$IFDEF BCB} |
| {$HPPEMIT '#ifndef NO_WIN32_LEAN_AND_MEAN'} |
| {$HPPEMIT '"Error: The NO_WIN32_LEAN_AND_MEAN symbol must be defined in your projects conditional defines"'} |
| {$HPPEMIT '#endif'} |
| {$ENDIF} |
| const |
| DROPEFFECT_NONE = ActiveX.DROPEFFECT_NONE; |
| DROPEFFECT_COPY = ActiveX.DROPEFFECT_COPY; |
| DROPEFFECT_MOVE = ActiveX.DROPEFFECT_MOVE; |
| DROPEFFECT_LINK = ActiveX.DROPEFFECT_LINK; |
| DROPEFFECT_SCROLL = ActiveX.DROPEFFECT_SCROLL; |
| type |
| // TDragType enumerates the three possible drag/drop operations. |
| TDragType = (dtCopy, dtMove, dtLink); |
| TDragTypes = set of TDragType; |
| type |
| // TDataDirection is used by the clipboard format registration to specify |
| // if the clipboard format should be listed in get (read) format enumerations, |
| // set (write) format enumerations or both. |
| // ddRead : Destination (IDropTarget) can read data from IDataObject. |
| // ddWrite : Destination (IDropTarget) can write data to IDataObject. |
| TDataDirection = (ddRead, ddWrite); |
| TDataDirections = set of TDataDirection; |
| const |
| ddReadWrite = [ddRead, ddWrite]; |
| type |
| // TConversionScope is used by the clipboard format registration to specify |
| // if a clipboard format conversion is supported by the drop source, the drop |
| // target or both. |
| // ddSource : Conversion is valid for drop source (IDropSource). |
| // ddTarget : Conversion is valid for drop target (IDropTarget). |
| TConversionScope = (csSource, csTarget); |
| TConversionScopes = set of TConversionScope; |
| const |
| csSourceTarget = [csSource, csTarget]; |
| // C++ Builder's declaration of IEnumFORMATETC is incorrect, so we must generate |
| // the typedef for C++ Builder. |
| {$IFDEF BCB} |
| {$HPPEMIT 'typedef System::DelphiInterface<IEnumFORMATETC> _di_IEnumFORMATETC;' } |
| {$ENDIF} |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TInterfacedComponent |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Top level base class for the drag/drop component hierachy. |
| // Implements the IUnknown interface. |
| // Corresponds to TInterfacedObject (see VCL on-line help), but descends from |
| // TComponent instead of TObject. |
| // Reference counting is disabled (_AddRef and _Release methods does nothing) |
| // since the component life span is controlled by the component owner. |
| //////////////////////////////////////////////////////////////////////////////// |
| type |
| TInterfacedComponent = class(TComponent, IUnknown) |
| protected |
| function QueryInterface(const IID: TGuid; out Obj): HRESULT; |
| {$IFDEF VER13_PLUS} override; {$ELSE} |
| {$IFDEF VER12_PLUS} reintroduce; {$ENDIF}{$ENDIF} stdcall; |
| function _AddRef: Integer; stdcall; |
| function _Release: Integer; stdcall; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Abstract base class. Extracts or injects data of a specific low level format |
| // from or to an IDataObject. |
| //////////////////////////////////////////////////////////////////////////////// |
| type |
| TCustomDataFormat = class; |
| TClipboardFormat = class(TObject) |
| private |
| FDataDirections: TDataDirections; |
| FDataFormat: TCustomDataFormat; |
| protected |
| FFormatEtc: TFormatEtc; |
| constructor CreateFormat(Atymed: Longint); virtual; |
| constructor CreateFormatEtc(const AFormatEtc: TFormatEtc); virtual; |
| { Extracts data from the specified medium } |
| function DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean; virtual; |
| { Transfer data to the specified medium } |
| function DoSetData(const FormatEtcIn: TFormatEtc; |
| var AMedium: TStgMedium): boolean; virtual; |
| function GetClipboardFormat: TClipFormat; virtual; |
| procedure SetClipboardFormat(Value: TClipFormat); virtual; |
| function GetClipboardFormatName: string; virtual; |
| procedure SetClipboardFormatName(const Value: string); virtual; |
| procedure SetFormatEtc(const Value: TFormatEtc); |
| public |
| constructor Create; virtual; abstract; |
| destructor Destroy; override; |
| { Determines if the object can read from the specified data object } |
| function HasValidFormats(ADataObject: IDataObject): boolean; virtual; |
| { Determines if the object can read the specified format } |
| function AcceptFormat(const AFormatEtc: TFormatEtc): boolean; virtual; |
| { Extracts data from the specified IDataObject } |
| function GetData(ADataObject: IDataObject): boolean; virtual; |
| { Extracts data from the specified IDataObject via the specified medium } |
| function GetDataFromMedium(ADataObject: IDataObject; |
| var AMedium: TStgMedium): boolean; virtual; |
| { Transfers data to the specified IDataObject } |
| function SetData(ADataObject: IDataObject; const FormatEtcIn: TFormatEtc; |
| var AMedium: TStgMedium): boolean; virtual; |
| { Transfers data to the specified medium } |
| function SetDataToMedium(const FormatEtcIn: TFormatEtc; |
| var AMedium: TStgMedium): boolean; |
| { Copies data from the specified source format to the object } |
| function Assign(Source: TCustomDataFormat): boolean; virtual; |
| { Copies data from the object to the specified target format } |
| function AssignTo(Dest: TCustomDataFormat): boolean; virtual; |
| { Clears the objects data } |
| procedure Clear; virtual; abstract; |
| { Returns true if object can supply data } |
| function HasData: boolean; virtual; |
| { Unregisters the clipboard format and all mappings involving it from the global database } |
| class procedure UnregisterClipboardFormat; |
| { Returns the clipboard format value } |
| property ClipboardFormat: TClipFormat read GetClipboardFormat |
| write SetClipboardFormat; |
| { Returns the clipboard format name } |
| property ClipboardFormatName: string read GetClipboardFormatName |
| write SetClipboardFormatName; |
| { Provides access to the objects format specification } |
| property FormatEtc: TFormatEtc read FFormatEtc; |
| { Specifies whether the format can read and write data } |
| property DataDirections: TDataDirections read FDataDirections |
| write FDataDirections; |
| { Specifies the data format which owns and controls this clipboard format } |
| property DataFormat: TCustomDataFormat read FDataFormat write FDataFormat; |
| end; |
| TClipboardFormatClass = class of TClipboardFormat; |
| // TClipboardFormats |
| // List of TClipboardFormat objects. |
| TClipboardFormats = class(TObject) |
| private |
| FList: TList; |
| FOwnsObjects: boolean; |
| FDataFormat: TCustomDataFormat; |
| protected |
| function GetFormat(Index: integer): TClipboardFormat; |
| function GetCount: integer; |
| public |
| constructor Create(ADataFormat: TCustomDataFormat; AOwnsObjects: boolean); |
| destructor Destroy; override; |
| procedure Clear; |
| function Add(ClipboardFormat: TClipboardFormat): integer; |
| function Contain(ClipboardFormatClass: TClipboardFormatClass): boolean; |
| function FindFormat(ClipboardFormatClass: TClipboardFormatClass): TClipboardFormat; |
| property Formats[Index: integer]: TClipboardFormat read GetFormat; default; |
| property Count: integer read GetCount; |
| property DataFormat: TCustomDataFormat read FDataFormat; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDragDropComponent |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Base class for drag/drop components. |
| //////////////////////////////////////////////////////////////////////////////// |
| TDataFormats = class; |
| TDragDropComponent = class(TInterfacedComponent) |
| private |
| protected |
| FDataFormats: TDataFormats; |
| //: Only used by TCustomDropMultiSource and TCustomDropMultiTarget and |
| // their descendants. |
| property DataFormats: TDataFormats read FDataFormats; |
| public |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Abstract base class. |
| // Renders the data of one or more TClipboardFormat objects to or from a |
| // specific high level data format. |
| //////////////////////////////////////////////////////////////////////////////// |
| TCustomDataFormat = class(TObject) |
| private |
| FCompatibleFormats : TClipboardFormats; |
| FFormatList : TDataFormats; |
| FOwner : TDragDropComponent; |
| FOnChanging : TNotifyEvent; |
| protected |
| { Determines if the object can accept data from the specified source format } |
| function SupportsFormat(ClipboardFormat: TClipboardFormat): boolean; |
| procedure DoOnChanging(Sender: TObject); |
| procedure Changing; virtual; |
| property FormatList: TDataFormats read FFormatList; |
| public |
| constructor Create(AOwner: TDragDropComponent); virtual; |
| destructor Destroy; override; |
| procedure Clear; virtual; abstract; |
| { Copies data between the specified clipboard format to the object } |
| function Assign(Source: TClipboardFormat): boolean; virtual; |
| function AssignTo(Dest: TClipboardFormat): boolean; virtual; |
| { Extracts data from the specified IDataObject } |
| function GetData(DataObject: IDataObject): boolean; virtual; |
| { Determines if the object contains *any* data } |
| function HasData: boolean; virtual; abstract; |
| { Determines if the object needs/can use *more* data } |
| function NeedsData: boolean; virtual; |
| { Determines if the object can read from the specified data object } |
| function HasValidFormats(ADataObject: IDataObject): boolean; virtual; |
| { Determines if the object can read the specified format } |
| function AcceptFormat(const FormatEtc: TFormatEtc): boolean; virtual; |
| { Registers the data format in the data format list } |
| class procedure RegisterDataFormat; |
| { Registers the specified clipboard format as being compatible with the data format } |
| class procedure RegisterCompatibleFormat(ClipboardFormatClass: TClipboardFormatClass; |
| Priority: integer {$ifdef VER12_PLUS} = 0 {$endif}; |
| ConversionScopes: TConversionScopes {$ifdef VER12_PLUS} = csSourceTarget {$endif}; |
| DataDirections: TDataDirections {$ifdef VER12_PLUS} = [ddRead] {$endif}); |
| { Unregisters the specified clipboard format from the compatibility list } |
| class procedure UnregisterCompatibleFormat(ClipboardFormatClass: TClipboardFormatClass); |
| { Unregisters data format and all mappings involving it from the global database } |
| class procedure UnregisterDataFormat; |
| { List of compatible source formats } |
| property CompatibleFormats: TClipboardFormats read FCompatibleFormats; |
| property Owner: TDragDropComponent read FOwner; |
| property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; |
| // TODO : Add support for delayed rendering with DelayedRender property. |
| end; |
| // TDataFormats |
| // List of TCustomDataFormat objects. |
| TDataFormats = class(TObject) |
| private |
| FList: TList; |
| protected |
| function GetFormat(Index: integer): TCustomDataFormat; |
| function GetCount: integer; |
| public |
| constructor Create; |
| destructor Destroy; override; |
| function Add(DataFormat: TCustomDataFormat): integer; virtual; |
| function IndexOf(DataFormat: TCustomDataFormat): integer; virtual; |
| procedure Remove(DataFormat: TCustomDataFormat); virtual; |
| property Formats[Index: integer]: TCustomDataFormat read GetFormat; default; |
| property Count: integer read GetCount; |
| end; |
| // TDataFormatClasses |
| // List of TCustomDataFormat classes. |
| TDataFormatClass = class of TCustomDataFormat; |
| TDataFormatClasses = class(TObject) |
| private |
| FList: TList; |
| protected |
| function GetFormat(Index: integer): TDataFormatClass; |
| function GetCount: integer; |
| { Provides singleton access to the global data format database } |
| class function Instance: TDataFormatClasses; |
| public |
| constructor Create; |
| destructor Destroy; override; |
| function Add(DataFormat: TDataFormatClass): integer; virtual; |
| procedure Remove(DataFormat: TDataFormatClass); virtual; |
| property Formats[Index: integer]: TDataFormatClass read GetFormat; default; |
| property Count: integer read GetCount; |
| end; |
| // TDataFormatMap |
| // Format conversion database. Contains mappings between TClipboardFormat |
| // and TCustomDataFormat. |
| // Used internally by TCustomDropMultiTarget and TCustomDropMultiSource. |
| TDataFormatMap = class(TObject) |
| FList: TList; |
| protected |
| function FindMap(DataFormatClass: TDataFormatClass; ClipboardFormatClass: TClipboardFormatClass): integer; |
| procedure Sort; |
| { Provides singleton access to the global format map database } |
| class function Instance: TDataFormatMap; |
| public |
| constructor Create; |
| destructor Destroy; override; |
| procedure Add(DataFormatClass: TDataFormatClass; |
| ClipboardFormatClass: TClipboardFormatClass; |
| Priority: integer {$ifdef VER12_PLUS} = 0 {$endif}; |
| ConversionScopes: TConversionScopes {$ifdef VER12_PLUS} = csSourceTarget {$endif}; |
| DataDirections: TDataDirections {$ifdef VER12_PLUS} = [ddRead] {$endif}); |
| procedure Delete(DataFormatClass: TDataFormatClass; |
| ClipboardFormatClass: TClipboardFormatClass); |
| procedure DeleteByClipboardFormat(ClipboardFormatClass: TClipboardFormatClass); |
| procedure DeleteByDataFormat(DataFormatClass: TDataFormatClass); |
| procedure GetSourceByDataFormat(DataFormatClass: TDataFormatClass; |
| ClipboardFormats: TClipboardFormats; ConversionScope: TConversionScope); |
| function CanMap(DataFormatClass: TDataFormatClass; |
| ClipboardFormatClass: TClipboardFormatClass): boolean; |
| { Registers the specified format mapping } |
| procedure RegisterFormatMap(DataFormatClass: TDataFormatClass; |
| ClipboardFormatClass: TClipboardFormatClass; |
| Priority: integer {$ifdef VER12_PLUS} = 0 {$endif}; |
| ConversionScopes: TConversionScopes {$ifdef VER12_PLUS} = csSourceTarget {$endif}; |
| DataDirections: TDataDirections {$ifdef VER12_PLUS} = [ddRead] {$endif}); |
| { Unregisters the specified format mapping } |
| procedure UnregisterFormatMap(DataFormatClass: TDataFormatClass; |
| ClipboardFormatClass: TClipboardFormatClass); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDataFormatAdapter |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Helper component used to add additional data formats to a drop source or |
| // target at design time. |
| // Requires that data formats have been registered with |
| // TCustomDataFormat.RegisterDataFormat. |
| //////////////////////////////////////////////////////////////////////////////// |
| TDataFormatAdapter = class(TComponent) |
| private |
| FDragDropComponent: TDragDropComponent; |
| FDataFormat: TCustomDataFormat; |
| FDataFormatClass: TDataFormatClass; |
| FEnabled: boolean; |
| function GetDataFormatName: string; |
| procedure SetDataFormatName(const Value: string); |
| protected |
| procedure SetDataFormatClass(const Value: TDataFormatClass); |
| procedure SetDragDropComponent(const Value: TDragDropComponent); |
| function GetEnabled: boolean; |
| procedure SetEnabled(const Value: boolean); |
| procedure Notification(AComponent: TComponent; |
| Operation: TOperation); override; |
| procedure Loaded; override; |
| public |
| destructor Destroy; override; |
| property DataFormatClass: TDataFormatClass read FDataFormatClass |
| write SetDataFormatClass; |
| property DataFormat: TCustomDataFormat read FDataFormat; |
| published |
| property DragDropComponent: TDragDropComponent read FDragDropComponent |
| write SetDragDropComponent; |
| property DataFormatName: string read GetDataFormatName |
| write SetDataFormatName; |
| property Enabled: boolean read GetEnabled write SetEnabled; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Drag Drop helper interfaces |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Requires Windows 2000 or later. |
| //////////////////////////////////////////////////////////////////////////////// |
| type |
| PSHDRAGIMAGE = ^TSHDRAGIMAGE; |
| {_$EXTERNALSYM _SHDRAGIMAGE} |
| _SHDRAGIMAGE = packed record |
| sizeDragImage: TSize; { The length and Width of the rendered image } |
| ptOffset: TPoint; { The Offset from the mouse cursor to the upper left corner of the image } |
| hbmpDragImage: HBitmap; { The Bitmap containing the rendered drag images } |
| crColorKey: COLORREF; { The COLORREF that has been blitted to the background of the images } |
| end; |
| TSHDRAGIMAGE = _SHDRAGIMAGE; |
| {_$EXTERNALSYM SHDRAGIMAGE} |
| SHDRAGIMAGE = _SHDRAGIMAGE; |
| const |
| CLSID_DragDropHelper: TGUID = ( |
| D1:$4657278a; D2:$411b; D3:$11d2; D4:($83,$9a,$00,$c0,$4f,$d9,$18,$d0)); |
| SID_DragDropHelper = '{4657278A-411B-11d2-839A-00C04FD918D0}'; |
| const |
| IID_IDropTargetHelper: TGUID = ( |
| D1:$4657278b; D2:$411b; D3:$11d2; D4:($83,$9a,$00,$c0,$4f,$d9,$18,$d0)); |
| SID_IDropTargetHelper = '{4657278B-411B-11d2-839A-00C04FD918D0}'; |
| type |
| {_$HPPEMIT 'typedef DragDrop::DelphiInterface<IDropTargetHelper> _di_IDropTargetHelper;'} |
| {_$EXTERNALSYM IDropTargetHelper} |
| IDropTargetHelper = interface(IUnknown) |
| [SID_IDropTargetHelper] |
| function DragEnter(hwndTarget: HWND; const DataObj: IDataObject; |
| var pt: TPoint; dwEffect: Longint): HResult; stdcall; |
| function DragLeave: HResult; stdcall; |
| function DragOver(var pt: TPoint; dwEffect: longInt): HResult; stdcall; |
| function Drop(const DataObj: IDataObject; var pt: TPoint; |
| dwEffect: longInt): HResult; stdcall; |
| function Show(Show: BOOL): HResult; stdcall; |
| end; |
| const |
| IID_IDragSourceHelper: TGUID = ( |
| D1:$de5bf786; D2:$477a; D3:$11d2; D4:($83,$9d,$00,$c0,$4f,$d9,$18,$d0)); |
| SID_IDragSourceHelper = '{DE5BF786-477A-11d2-839D-00C04FD918D0}'; |
| type |
| {_$HPPEMIT 'typedef DragDrop::DelphiInterface<IDragSourceHelper> _di_IDragSourceHelper;'} |
| {_$EXTERNALSYM IDragSourceHelper} |
| IDragSourceHelper = interface(IUnknown) |
| [SID_IDragSourceHelper] |
| function InitializeFromBitmap(var shdi: TSHDRAGIMAGE; |
| const DataObj: IDataObject): HResult; stdcall; |
| function InitializeFromWindow(hwnd: HWND; var pt: TPoint; |
| const DataObj: IDataObject): HResult; stdcall; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Async data transfer interfaces |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Requires Windows 2000 or later. |
| //////////////////////////////////////////////////////////////////////////////// |
| const |
| IID_IAsyncOperation: TGUID = ( |
| D1:$3D8B0590; D2:$F691; D3:$11D2; D4:($8E,$A9,$00,$60,$97,$DF,$5B,$D4)); |
| SID_IAsyncOperation = '{3D8B0590-F691-11D2-8EA9-006097DF5BD4}'; |
| type |
| {_$HPPEMIT 'typedef DragDrop::DelphiInterface<IAsyncOperation> _di_IAsyncOperation;'} |
| {_$EXTERNALSYM IAsyncOperation} |
| IAsyncOperation = interface(IUnknown) |
| [SID_IAsyncOperation] |
| function SetAsyncMode(fDoOpAsync: BOOL): HResult; stdcall; |
| function GetAsyncMode(out fDoOpAsync: BOOL): HResult; stdcall; |
| function StartOperation(const pbcReserved: IBindCtx): HResult; stdcall; |
| function InOperation(out pfInAsyncOp: BOOL): HResult; stdcall; |
| function EndOperation(hResult: HRESULT; const pbcReserved: IBindCtx; |
| dwEffects: DWORD): HResult; stdcall; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TRawClipboardFormat & TRawDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // These clipboard and data format classes are special in that they don't |
| // interpret the data in any way. |
| // Their primary purpose is to enable the TCustomDropMultiSource class to accept |
| // and store arbitrary (and unknown) data types. This is a requirement for |
| // drag drop helper object support. |
| //////////////////////////////////////////////////////////////////////////////// |
| // The TRawDataFormat class does not perform any storage of data itself. Instead |
| // it relies on the TRawClipboardFormat objects to store data. |
| //////////////////////////////////////////////////////////////////////////////// |
| TRawDataFormat = class(TCustomDataFormat) |
| private |
| FMedium: TStgMedium; |
| protected |
| public |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function NeedsData: boolean; override; |
| property Medium: TStgMedium read FMedium write FMedium; |
| end; |
| TRawClipboardFormat = class(TClipboardFormat) |
| private |
| FMedium: TStgMedium; |
| protected |
| function DoGetData(ADataObject: IDataObject; |
| const AMedium: TStgMedium): boolean; override; |
| function DoSetData(const FormatEtcIn: TFormatEtc; |
| var AMedium: TStgMedium): boolean; override; |
| procedure SetClipboardFormatName(const Value: string); override; |
| function GetClipboardFormat: TClipFormat; override; |
| function GetString: string; |
| procedure SetString(const Value: string); |
| public |
| constructor Create; override; |
| constructor CreateFormatEtc(const AFormatEtc: TFormatEtc); override; |
| function Assign(Source: TCustomDataFormat): boolean; override; |
| function AssignTo(Dest: TCustomDataFormat): boolean; override; |
| procedure Clear; override; |
| // Methods to handle the corresponding TRawDataFormat functioinality. |
| procedure ClearData; |
| function HasData: boolean; override; |
| function NeedsData: boolean; |
| // All of these should be moved/mirrored in TRawDataFormat: |
| procedure CopyFromStgMedium(const AMedium: TStgMedium); |
| procedure CopyToStgMedium(var AMedium: TStgMedium); |
| property AsString: string read GetString write SetString; |
| property Medium: TStgMedium read FMedium write FMedium; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Utility functions |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function DropEffectToDragType(DropEffect: longInt; var DragType: TDragType): boolean; |
| function DragTypesToDropEffect(DragTypes: TDragTypes): longint; // V4: New |
| // Coordinate space conversion. |
| function ClientPtToWindowPt(Handle: THandle; pt: TPoint): TPoint; |
| // Replacement for KeysToShiftState. |
| function KeysToShiftStatePlus(Keys: Word): TShiftState; // V4: New |
| function ShiftStateToDropEffect(Shift: TShiftState; AllowedEffects: longint; |
| Fallback: boolean): longint; |
| // Replacement for the buggy DragDetect API function. |
| function DragDetectPlus(Handle: THandle; p: TPoint): boolean; // V4: New |
| // Wrapper for urlmon.CopyStgMedium. |
| // Note: Only works with IE4 or later installed. |
| function CopyStgMedium(const SrcMedium: TStgMedium; var DstMedium: TStgMedium): boolean; |
| // Get the name of a clipboard format as a Delphi string. |
| function GetClipboardFormatNameStr(Value: TClipFormat): string; |
| // Raise last Windows API error as an exception. |
| procedure _RaiseLastWin32Error; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Global variables |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| ShellMalloc: IMalloc; |
| // Name of the IDE component palette page the drag drop components are |
| // registered to |
| var |
| DragDropComponentPalettePage: string = 'DragDrop'; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Misc drop target related constants |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Drag Drop constants from ActiveX unit |
| var |
| // Default inset-width of the auto scroll hot zone. |
| // Specified in pixels. |
| // Not used! Instead the height of the target control's font is used. |
| DragDropScrollInset: integer = DD_DEFSCROLLINSET; // 11 |
| // Default delay after entering the scroll zone, before scrolling starts. |
| // Specified in milliseconds. |
| DragDropScrollDelay: integer = DD_DEFSCROLLDELAY; // 50 |
| // Default scroll interval during auto scroll. |
| // Specified in milliseconds. |
| DragDropScrollInterval: integer = DD_DEFSCROLLINTERVAL; // 50 |
| // Default delay before dragging should start. |
| // Specified in milliseconds. |
| DragDropDragDelay: integer = DD_DEFDRAGDELAY; // 200 |
| // Default minimum distance (radius) before dragging should start. |
| // Specified in pixels. |
| // Not used! Instead the SM_CXDRAG and SM_CYDRAG system metrics are used. |
| DragDropDragMinDistance: integer = DD_DEFDRAGMINDIST; // 2 |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Misc drag drop API related constants |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // The following DVASPECT constants are missing from some versions of Delphi and |
| // C++ Builder. |
| {$ifndef VER135_PLUS} |
| const |
| {$ifndef VER10_PLUS} |
| DVASPECT_SHORTNAME = 2; // use for CF_HDROP to get short name version of file paths |
| {$endif} |
| DVASPECT_COPY = 3; // use to indicate format is a "Copy" of the data (FILECONTENTS, FILEDESCRIPTOR, etc) |
| DVASPECT_LINK = 4; // use to indicate format is a "Shortcut" to the data (FILECONTENTS, FILEDESCRIPTOR, etc) |
| {$endif} |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| (******************************************************************************* |
| ** |
| ** IMPLEMENTATION |
| ** |
| *******************************************************************************) |
| implementation |
| uses |
| {$ifdef DEBUG} |
| ComObj, |
| {$endif} |
| DropSource, |
| DropTarget, |
| DragDropFormats, // Used by TRawClipboardFormat |
| Messages, |
| ShlObj, |
| MMSystem, |
| SysUtils; |
| resourcestring |
| sImplementationRequired = 'Internal error: %s.%s needs implementation'; |
| sInvalidOwnerType = '%s is not a valid owner for %s. Owner must be derived from %s'; |
| sFormatNameReadOnly = '%s.ClipboardFormat is read-only'; |
| sNoCopyStgMedium = 'A required system function (URLMON.CopyStgMedium) was not available on this system. Operation aborted.'; |
| sBadConstructor = 'The %s class can not be instantiated with the default constructor'; |
| sUnregisteredDataFormat = 'The %s data format has not been registered by any of the used units'; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| begin |
| RegisterComponents(DragDropComponentPalettePage, [TDataFormatAdapter]); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TInterfacedComponent |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TInterfacedComponent.QueryInterface(const IID: TGuid; out Obj): HRESULT; |
| {$ifdef DEBUG} |
| function GuidToString(const IID: TGuid): string; |
| var |
| GUID: string; |
| begin |
| GUID := ComObj.GUIDToString(IID); |
| Result := GetRegStringValue('Interface\'+GUID, ''); |
| if (Result = '') then |
| Result := GUID; |
| end; |
| {$endif} |
| begin |
| {$ifdef VER12_PLUS} |
| if GetInterface(IID, Obj) then |
| Result := 0 |
| else if (VCLComObject <> nil) then |
| Result := IVCLComObject(VCLComObject).QueryInterface(IID, Obj) |
| else |
| Result := E_NOINTERFACE; |
| {$else} |
| Result := inherited QueryInterface(IID, Obj); |
| {$endif} |
| {$ifdef DEBUG} |
| OutputDebugString(PChar(format('%s.QueryInterface(%s): %d (%d)', |
| [ClassName, GuidToString(IID), Result, ord(pointer(Obj) <> nil)]))); |
| {$endif} |
| end; |
| function TInterfacedComponent._AddRef: Integer; |
| var |
| Outer: IUnknown; |
| begin |
| // In case we are the inner object of an aggregation, we attempt to delegate |
| // the reference counting to the outer object. We assume that the component |
| // owner is the outer object. |
| if (Owner <> nil) and (Owner.GetInterface(IUnknown, Outer)) then |
| Result := Outer._AddRef |
| else |
| begin |
| {$ifdef VER12_PLUS} |
| inherited _AddRef; |
| {$else} |
| if (VCLComObject <> nil) then |
| inherited _AddRef; |
| {$endif} |
| Result := -1; |
| end; |
| end; |
| function TInterfacedComponent._Release: Integer; |
| var |
| Outer: IUnknown; |
| begin |
| // See _AddRef for comments. |
| if (Owner <> nil) and (Owner.GetInterface(IUnknown, Outer)) then |
| Result := Outer._Release |
| else |
| begin |
| {$ifdef VER12_PLUS} |
| inherited _Release; |
| {$else} |
| if (VCLComObject <> nil) then |
| inherited _Release; |
| {$endif} |
| Result := -1; |
| end; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| destructor TClipboardFormat.Destroy; |
| begin |
| // Warning: Do not call Clear here. Descendant class has already |
| // cleaned up and released resources! |
| inherited Destroy; |
| end; |
| constructor TClipboardFormat.CreateFormat(Atymed: Longint); |
| begin |
| inherited Create; |
| FDataDirections := [ddRead]; |
| FFormatEtc.cfFormat := ClipboardFormat; |
| FFormatEtc.ptd := nil; |
| FFormatEtc.dwAspect := DVASPECT_CONTENT; |
| FFormatEtc.lindex := -1; |
| FFormatEtc.tymed := Atymed; |
| end; |
| constructor TClipboardFormat.CreateFormatEtc(const AFormatEtc: TFormatEtc); |
| begin |
| inherited Create; |
| FDataDirections := [ddRead]; |
| FFormatEtc := AFormatEtc; |
| end; |
| function TClipboardFormat.HasValidFormats(ADataObject: IDataObject): boolean; |
| begin |
| Result := (ADataObject.QueryGetData(FormatEtc) = S_OK); |
| end; |
| function TClipboardFormat.AcceptFormat(const AFormatEtc: TFormatEtc): boolean; |
| begin |
| Result := (AFormatEtc.cfFormat = FFormatEtc.cfFormat) and |
| (AFormatEtc.ptd = nil) and |
| (AFormatEtc.dwAspect = FFormatEtc.dwAspect) and |
| (AFormatEtc.tymed AND FFormatEtc.tymed <> 0); |
| end; |
| function TClipboardFormat.Assign(Source: TCustomDataFormat): boolean; |
| begin |
| Result := False; |
| end; |
| function TClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean; |
| begin |
| Result := False; |
| end; |
| function TClipboardFormat.DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean; |
| begin |
| Result := False; |
| end; |
| function TClipboardFormat.DoSetData(const FormatEtcIn: TFormatEtc; |
| var AMedium: TStgMedium): boolean; |
| begin |
| Result := False; |
| end; |
| function TClipboardFormat.GetData(ADataObject: IDataObject): boolean; |
| var |
| Medium : TStgMedium; |
| begin |
| Result := False; |
| Clear; |
| if (ADataObject.GetData(FFormatEtc, Medium) <> S_OK) then |
| exit; |
| Result := GetDataFromMedium(ADataObject, Medium); |
| end; |
| function TClipboardFormat.GetDataFromMedium(ADataObject: IDataObject; |
| var AMedium: TStgMedium): boolean; |
| begin |
| Result := False; |
| try |
| Clear; |
| if ((AMedium.tymed AND FFormatEtc.tymed) <> 0) then |
| Result := DoGetData(ADataObject, AMedium); |
| finally |
| ReleaseStgMedium(AMedium); |
| end; |
| end; |
| function TClipboardFormat.SetDataToMedium(const FormatEtcIn: TFormatEtc; |
| var AMedium: TStgMedium): boolean; |
| begin |
| Result := False; |
| FillChar(AMedium, SizeOf(AMedium), 0); |
| if (FormatEtcIn.cfFormat <> FFormatEtc.cfFormat) or |
| (FormatEtcIn.dwAspect <> FFormatEtc.dwAspect) or |
| (FormatEtcIn.tymed and FFormatEtc.tymed = 0) then |
| exit; |
| // Call descendant to allocate medium and transfer data to it |
| Result := DoSetData(FormatEtcIn, AMedium); |
| end; |
| function TClipboardFormat.SetData(ADataObject: IDataObject; |
| const FormatEtcIn: TFormatEtc; var AMedium: TStgMedium): boolean; |
| begin |
| // Transfer data to medium |
| Result := SetDataToMedium(FormatEtcIn, AMedium); |
| // Call IDataObject to set data |
| if (Result) then |
| Result := (ADataObject.SetData(FormatEtc, AMedium, True) = S_OK); |
| // If we didn't succeed in transfering ownership of the data medium to the |
| // IDataObject, we must deallocate the medium ourselves. |
| if (not Result) then |
| ReleaseStgMedium(AMedium); |
| end; |
| class procedure TClipboardFormat.UnregisterClipboardFormat; |
| begin |
| TDataFormatMap.Instance.DeleteByClipboardFormat(Self); |
| end; |
| function TClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| // This should have been a virtual abstract class method, but this isn't supported by C++ Builder. |
| raise Exception.CreateFmt(sImplementationRequired, [ClassName, 'GetClipboardFormat']); |
| end; |
| procedure TClipboardFormat.SetClipboardFormat(Value: TClipFormat); |
| begin |
| FFormatEtc.cfFormat := Value; |
| end; |
| function TClipboardFormat.GetClipboardFormatName: string; |
| var |
| Len : integer; |
| begin |
| SetLength(Result, 255); // 255 is just an artificial limit. |
| Len := Windows.GetClipboardFormatName(GetClipboardFormat, PChar(Result), 255); |
| SetLength(Result, Len); |
| end; |
| procedure TClipboardFormat.SetClipboardFormatName(const Value: string); |
| begin |
| raise Exception.CreateFmt(sFormatNameReadOnly, [ClassName]); |
| end; |
| function TClipboardFormat.HasData: boolean; |
| begin |
| // Descendant classes are not required to override this method, so by default |
| // we just pretend that data is available. No harm is done by this. |
| Result := True; |
| end; |
| procedure TClipboardFormat.SetFormatEtc(const Value: TFormatEtc); |
| begin |
| FFormatEtc := Value; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TClipboardFormats |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TClipboardFormats.Create(ADataFormat: TCustomDataFormat; |
| AOwnsObjects: boolean); |
| begin |
| inherited Create; |
| FList := TList.Create; |
| FDataFormat := ADataFormat; |
| FOwnsObjects := AOwnsObjects; |
| end; |
| destructor TClipboardFormats.Destroy; |
| begin |
| Clear; |
| FList.Free; |
| inherited Destroy; |
| end; |
| function TClipboardFormats.Add(ClipboardFormat: TClipboardFormat): integer; |
| begin |
| Result := FList.Add(ClipboardFormat); |
| if (FOwnsObjects) and (DataFormat <> nil) then |
| ClipboardFormat.DataFormat := DataFormat; |
| end; |
| function TClipboardFormats.FindFormat(ClipboardFormatClass: TClipboardFormatClass): TClipboardFormat; |
| var |
| i : integer; |
| begin |
| // Search list for an object of the specified type |
| for i := 0 to Count-1 do |
| if (Formats[i].InheritsFrom(ClipboardFormatClass)) then |
| begin |
| Result := Formats[i]; |
| exit; |
| end; |
| Result := nil; |
| end; |
| function TClipboardFormats.Contain(ClipboardFormatClass: TClipboardFormatClass): boolean; |
| begin |
| Result := (FindFormat(ClipboardFormatClass) <> nil); |
| end; |
| function TClipboardFormats.GetCount: integer; |
| begin |
| Result := FList.Count; |
| end; |
| function TClipboardFormats.GetFormat(Index: integer): TClipboardFormat; |
| begin |
| Result := TClipboardFormat(FList[Index]); |
| end; |
| procedure TClipboardFormats.Clear; |
| var |
| i : integer; |
| Format : TObject; |
| begin |
| if (FOwnsObjects) then |
| // Empty list and delete all objects in it |
| for i := Count-1 downto 0 do |
| begin |
| Format := Formats[i]; |
| FList.Delete(i); |
| Format.Free; |
| end; |
| FList.Clear; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TCustomDataFormat.Create(AOwner: TDragDropComponent); |
| var |
| ConversionScope: TConversionScope; |
| begin |
| if (AOwner <> nil) then |
| begin |
| if (AOwner is TCustomDropMultiSource) then |
| ConversionScope := csSource |
| else if (AOwner is TCustomDropMultiTarget) then |
| ConversionScope := csTarget |
| else |
| raise Exception.CreateFmt(sInvalidOwnerType, [AOwner.ClassName, ClassName, |
| 'TCustomDropMultiSource or TCustomDropMultiTarget']); |
| // Add object to owners list of data formats. |
| FOwner := AOwner; |
| end else |
| // TODO : This sucks! All this ConversionScope stuff should be redesigned. |
| ConversionScope := csTarget; |
| FCompatibleFormats := TClipboardFormats.Create(Self, True); |
| // Populate list with all the clipboard formats that have been registered as |
| // compatible with this data format. |
| TDataFormatMap.Instance.GetSourceByDataFormat(TDataFormatClass(ClassType), |
| FCompatibleFormats, ConversionScope); |
| if (FOwner <> nil) then |
| FOwner.DataFormats.Add(Self); |
| end; |
| destructor TCustomDataFormat.Destroy; |
| begin |
| FCompatibleFormats.Free; |
| // Remove object from owners list of target formats |
| if (FOwner <> nil) then |
| FOwner.DataFormats.Remove(Self); |
| inherited Destroy; |
| end; |
| function TCustomDataFormat.Assign(Source: TClipboardFormat): boolean; |
| begin |
| // Called when derived class(es) couldn't convert from the source format. |
| // Try to let source format convert to this format instead. |
| Result := Source.AssignTo(Self); |
| end; |
| function TCustomDataFormat.AssignTo(Dest: TClipboardFormat): boolean; |
| begin |
| // Called when derived class(es) couldn't convert to the destination format. |
| // Try to let destination format convert from this format instead. |
| Result := Dest.Assign(Self); |
| end; |
| function TCustomDataFormat.GetData(DataObject: IDataObject): boolean; |
| var |
| i: integer; |
| begin |
| Result := False; |
| i := 0; |
| // Get data from each of our associated clipboard formats until we don't |
| // need anymore data. |
| while (NeedsData) and (i < CompatibleFormats.Count) do |
| begin |
| CompatibleFormats[i].Clear; |
| if (CompatibleFormats[i].GetData(DataObject)) and |
| (CompatibleFormats[i].HasData) then |
| begin |
| if (Assign(CompatibleFormats[i])) then |
| begin |
| // Once data has been sucessfully transfered to the TDataFormat object, |
| // we clear the data in the TClipboardFormat object in order to conserve |
| // resources. |
| CompatibleFormats[i].Clear; |
| Result := True; |
| end; |
| end; |
| inc(i); |
| end; |
| end; |
| function TCustomDataFormat.NeedsData: boolean; |
| begin |
| Result := not HasData; |
| end; |
| function TCustomDataFormat.HasValidFormats(ADataObject: IDataObject): boolean; |
| var |
| i: integer; |
| begin |
| // Determine if any of the registered clipboard formats can read from the |
| // specified data object. |
| Result := False; |
| for i := 0 to CompatibleFormats.Count-1 do |
| if (CompatibleFormats[i].HasValidFormats(ADataObject)) then |
| begin |
| Result := True; |
| break; |
| end; |
| end; |
| function TCustomDataFormat.AcceptFormat(const FormatEtc: TFormatEtc): boolean; |
| var |
| i: integer; |
| begin |
| // Determine if any of the registered clipboard formats can handle the |
| // specified clipboard format. |
| Result := False; |
| for i := 0 to CompatibleFormats.Count-1 do |
| if (CompatibleFormats[i].AcceptFormat(FormatEtc)) then |
| begin |
| Result := True; |
| break; |
| end; |
| end; |
| class procedure TCustomDataFormat.RegisterDataFormat; |
| begin |
| TDataFormatClasses.Instance.Add(Self); |
| end; |
| class procedure TCustomDataFormat.RegisterCompatibleFormat(ClipboardFormatClass: TClipboardFormatClass; |
| Priority: integer; ConversionScopes: TConversionScopes; |
| DataDirections: TDataDirections); |
| begin |
| // Register format mapping. |
| TDataFormatMap.Instance.RegisterFormatMap(Self, ClipboardFormatClass, |
| Priority, ConversionScopes, DataDirections); |
| end; |
| function TCustomDataFormat.SupportsFormat(ClipboardFormat: TClipboardFormat): boolean; |
| begin |
| Result := CompatibleFormats.Contain(TClipboardFormatClass(ClipboardFormat.ClassType)); |
| end; |
| class procedure TCustomDataFormat.UnregisterCompatibleFormat(ClipboardFormatClass: TClipboardFormatClass); |
| begin |
| // Unregister format mapping |
| TDataFormatMap.Instance.UnregisterFormatMap(Self, ClipboardFormatClass); |
| end; |
| class procedure TCustomDataFormat.UnregisterDataFormat; |
| begin |
| TDataFormatMap.Instance.DeleteByDataFormat(Self); |
| TDataFormatClasses.Instance.Remove(Self); |
| end; |
| procedure TCustomDataFormat.DoOnChanging(Sender: TObject); |
| begin |
| Changing; |
| end; |
| procedure TCustomDataFormat.Changing; |
| begin |
| if (Assigned(OnChanging)) then |
| OnChanging(Self); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDataFormats |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TDataFormats.Add(DataFormat: TCustomDataFormat): integer; |
| begin |
| Result := FList.IndexOf(DataFormat); |
| if (Result = -1) then |
| Result := FList.Add(DataFormat); |
| end; |
| constructor TDataFormats.Create; |
| begin |
| inherited Create; |
| FList := TList.Create; |
| end; |
| destructor TDataFormats.Destroy; |
| var |
| i: integer; |
| begin |
| for i := FList.Count-1 downto 0 do |
| Remove(TCustomDataFormat(FList[i])); |
| FList.Free; |
| inherited Destroy; |
| end; |
| function TDataFormats.GetCount: integer; |
| begin |
| Result := FList.Count; |
| end; |
| function TDataFormats.GetFormat(Index: integer): TCustomDataFormat; |
| begin |
| Result := TCustomDataFormat(FList[Index]); |
| end; |
| function TDataFormats.IndexOf(DataFormat: TCustomDataFormat): integer; |
| begin |
| Result := FList.IndexOf(DataFormat); |
| end; |
| procedure TDataFormats.Remove(DataFormat: TCustomDataFormat); |
| begin |
| FList.Remove(DataFormat); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDataFormatClasses |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TDataFormatClasses.Add(DataFormat: TDataFormatClass): integer; |
| begin |
| Result := FList.IndexOf(DataFormat); |
| if (Result = -1) then |
| Result := FList.Add(DataFormat); |
| end; |
| constructor TDataFormatClasses.Create; |
| begin |
| inherited Create; |
| FList := TList.Create; |
| end; |
| destructor TDataFormatClasses.Destroy; |
| var |
| i: integer; |
| begin |
| for i := FList.Count-1 downto 0 do |
| Remove(TDataFormatClass(FList[i])); |
| FList.Free; |
| inherited Destroy; |
| end; |
| function TDataFormatClasses.GetCount: integer; |
| begin |
| Result := FList.Count; |
| end; |
| function TDataFormatClasses.GetFormat(Index: integer): TDataFormatClass; |
| begin |
| Result := TDataFormatClass(FList[Index]); |
| end; |
| var |
| FDataFormatClasses: TDataFormatClasses = nil; |
| class function TDataFormatClasses.Instance: TDataFormatClasses; |
| begin |
| if (FDataFormatClasses = nil) then |
| FDataFormatClasses := TDataFormatClasses.Create; |
| Result := FDataFormatClasses; |
| end; |
| procedure TDataFormatClasses.Remove(DataFormat: TDataFormatClass); |
| begin |
| FList.Remove(DataFormat); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDataFormatMap |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| type |
| // TTargetFormat / TClipboardFormat association |
| TFormatMap = record |
| DataFormat: TDataFormatClass; |
| ClipboardFormat: TClipboardFormatClass; |
| Priority: integer; |
| ConversionScopes: TConversionScopes; |
| DataDirections: TDataDirections; |
| end; |
| PFormatMap = ^TFormatMap; |
| constructor TDataFormatMap.Create; |
| begin |
| inherited Create; |
| FList := TList.Create; |
| end; |
| destructor TDataFormatMap.Destroy; |
| var |
| i : integer; |
| begin |
| // Zap any mapings which hasn't been unregistered |
| // yet (actually an error condition) |
| for i := FList.Count-1 downto 0 do |
| Dispose(FList[i]); |
| FList.Free; |
| inherited Destroy; |
| end; |
| procedure TDataFormatMap.Sort; |
| var |
| i : integer; |
| NewMap : PFormatMap; |
| begin |
| // Note: We do not use the built-in Sort method of TList because |
| // we need to preserve the order in which the mappings were added. |
| // New mappings have higher precedence than old mappings (within the |
| // same priority). |
| // Preconditions: |
| // 1) The list is already sorted before a new mapping is added. |
| // 2) The new mapping is always added to the end of the list. |
| NewMap := PFormatMap(FList.Last); |
| // Scan the list for a map with the same TTargetFormat type |
| i := FList.Count-2; |
| while (i > 0) do |
| begin |
| if (PFormatMap(FList[i])^.DataFormat = NewMap^.DataFormat) then |
| begin |
| // Scan the list for a map with lower priority |
| repeat |
| if (PFormatMap(FList[i])^.Priority < NewMap^.Priority) then |
| begin |
| // Move the mapping to the new position |
| FList.Move(FList.Count-1, i+1); |
| exit; |
| end; |
| dec(i); |
| until (i < 0) or (PFormatMap(FList[i])^.DataFormat <> NewMap^.DataFormat); |
| // Move the mapping to the new position |
| FList.Move(FList.Count-1, i+1); |
| exit; |
| end; |
| dec(i); |
| end; |
| end; |
| procedure TDataFormatMap.Add(DataFormatClass: TDataFormatClass; |
| ClipboardFormatClass: TClipboardFormatClass; Priority: integer; |
| ConversionScopes: TConversionScopes; DataDirections: TDataDirections); |
| var |
| FormatMap : PFormatMap; |
| OldMap : integer; |
| begin |
| // Avoid duplicate mappings |
| OldMap := FindMap(DataFormatClass, ClipboardFormatClass); |
| if (OldMap = -1) then |
| begin |
| // Add new mapping... |
| New(FormatMap); |
| FList.Add(FormatMap); |
| FormatMap^.ConversionScopes := ConversionScopes; |
| FormatMap^.DataDirections := DataDirections; |
| end else |
| begin |
| // Replace old mapping... |
| FormatMap := FList[OldMap]; |
| FList.Move(OldMap, FList.Count-1); |
| FormatMap^.ConversionScopes := FormatMap^.ConversionScopes + ConversionScopes; |
| FormatMap^.DataDirections := FormatMap^.DataDirections + DataDirections; |
| end; |
| FormatMap^.ClipboardFormat := ClipboardFormatClass; |
| FormatMap^.DataFormat := DataFormatClass; |
| FormatMap^.Priority := Priority; |
| // ...and sort list |
| Sort; |
| end; |
| function TDataFormatMap.CanMap(DataFormatClass: TDataFormatClass; |
| ClipboardFormatClass: TClipboardFormatClass): boolean; |
| begin |
| Result := (FindMap(DataFormatClass, ClipboardFormatClass) <> -1); |
| end; |
| procedure TDataFormatMap.Delete(DataFormatClass: TDataFormatClass; |
| ClipboardFormatClass: TClipboardFormatClass); |
| var |
| Index : integer; |
| begin |
| Index := FindMap(DataFormatClass, ClipboardFormatClass); |
| if (Index <> -1) then |
| begin |
| Dispose(FList[Index]); |
| FList.Delete(Index); |
| end; |
| end; |
| procedure TDataFormatMap.DeleteByClipboardFormat(ClipboardFormatClass: TClipboardFormatClass); |
| var |
| i : integer; |
| begin |
| // Delete all mappings associated with the specified clipboard format |
| for i := FList.Count-1 downto 0 do |
| if (PFormatMap(FList[i])^.ClipboardFormat.InheritsFrom(ClipboardFormatClass)) then |
| begin |
| Dispose(FList[i]); |
| FList.Delete(i); |
| end; |
| end; |
| procedure TDataFormatMap.DeleteByDataFormat(DataFormatClass: TDataFormatClass); |
| var |
| i : integer; |
| begin |
| // Delete all mappings associated with the specified target format |
| for i := FList.Count-1 downto 0 do |
| if (PFormatMap(FList[i])^.DataFormat.InheritsFrom(DataFormatClass)) then |
| begin |
| Dispose(FList[i]); |
| FList.Delete(i); |
| end; |
| end; |
| function TDataFormatMap.FindMap(DataFormatClass: TDataFormatClass; |
| ClipboardFormatClass: TClipboardFormatClass): integer; |
| var |
| i : integer; |
| begin |
| for i := 0 to FList.Count-1 do |
| if (PFormatMap(FList[i])^.DataFormat.InheritsFrom(DataFormatClass)) and |
| (PFormatMap(FList[i])^.ClipboardFormat.InheritsFrom(ClipboardFormatClass)) then |
| begin |
| Result := i; |
| exit; |
| end; |
| Result := -1; |
| end; |
| procedure TDataFormatMap.GetSourceByDataFormat(DataFormatClass: TDataFormatClass; |
| ClipboardFormats: TClipboardFormats; ConversionScope: TConversionScope); |
| var |
| i: integer; |
| ClipboardFormat: TClipboardFormat; |
| begin |
| // Clear the list... |
| ClipboardFormats.Clear; |
| // ...and populate it with *instances* of all the clipbard |
| // formats associated with the specified target format and |
| // registered with the specified data direction. |
| for i := 0 to FList.Count-1 do |
| if (ConversionScope in PFormatMap(FList[i])^.ConversionScopes) and |
| (PFormatMap(FList[i])^.DataFormat.InheritsFrom(DataFormatClass)) then |
| begin |
| ClipboardFormat := PFormatMap(FList[i])^.ClipboardFormat.Create; |
| ClipboardFormat.DataDirections := PFormatMap(FList[i])^.DataDirections; |
| ClipboardFormats.Add(ClipboardFormat); |
| end; |
| end; |
| procedure TDataFormatMap.RegisterFormatMap(DataFormatClass: TDataFormatClass; |
| ClipboardFormatClass: TClipboardFormatClass; Priority: integer; |
| ConversionScopes: TConversionScopes; DataDirections: TDataDirections); |
| begin |
| Add(DataFormatClass, ClipboardFormatClass, Priority, ConversionScopes, |
| DataDirections); |
| end; |
| procedure TDataFormatMap.UnregisterFormatMap(DataFormatClass: TDataFormatClass; |
| ClipboardFormatClass: TClipboardFormatClass); |
| begin |
| Delete(DataFormatClass, ClipboardFormatClass); |
| end; |
| var |
| FDataFormatMap: TDataFormatMap = nil; |
| class function TDataFormatMap.Instance: TDataFormatMap; |
| begin |
| if (FDataFormatMap = nil) then |
| FDataFormatMap := TDataFormatMap.Create; |
| Result := FDataFormatMap; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDataFormatAdapter |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| destructor TDataFormatAdapter.Destroy; |
| begin |
| inherited Destroy; |
| end; |
| function TDataFormatAdapter.GetDataFormatName: string; |
| begin |
| if Assigned(FDataFormatClass) then |
| Result := FDataFormatClass.ClassName |
| else |
| Result := ''; |
| end; |
| function TDataFormatAdapter.GetEnabled: boolean; |
| begin |
| if (csDesigning in ComponentState) then |
| Result := FEnabled |
| else |
| Result := Assigned(FDataFormat) and Assigned(FDataFormatClass); |
| end; |
| procedure TDataFormatAdapter.Loaded; |
| begin |
| inherited; |
| if (FEnabled) then |
| Enabled := True; |
| end; |
| procedure TDataFormatAdapter.Notification(AComponent: TComponent; |
| Operation: TOperation); |
| begin |
| if (Operation = opRemove) and (AComponent = FDragDropComponent) then |
| DragDropComponent := nil; |
| inherited; |
| end; |
| procedure TDataFormatAdapter.SetDataFormatClass(const Value: TDataFormatClass); |
| begin |
| if (Value <> FDataFormatClass) then |
| begin |
| if not(csLoading in ComponentState) then |
| Enabled := False; |
| FDataFormatClass := Value; |
| end; |
| end; |
| procedure TDataFormatAdapter.SetDataFormatName(const Value: string); |
| var |
| i: integer; |
| ADataFormatClass: TDataFormatClass; |
| begin |
| ADataFormatClass := nil; |
| if (Value <> '') then |
| begin |
| for i := 0 to TDataFormatClasses.Instance.Count-1 do |
| if (AnsiCompareText(TDataFormatClasses.Instance[i].ClassName, Value) = 0) then |
| begin |
| ADataFormatClass := TDataFormatClasses.Instance[i]; |
| break; |
| end; |
| if (ADataFormatClass = nil) then |
| raise Exception.CreateFmt(sUnregisteredDataFormat, [Value]); |
| end; |
| DataFormatClass := ADataFormatClass; |
| end; |
| procedure TDataFormatAdapter.SetDragDropComponent(const Value: TDragDropComponent); |
| begin |
| if (Value <> FDragDropComponent) then |
| begin |
| if not(csLoading in ComponentState) then |
| Enabled := False; |
| if (FDragDropComponent <> nil) then |
| FDragDropComponent.RemoveFreeNotification(Self); |
| FDragDropComponent := Value; |
| if (Value <> nil) then |
| Value.FreeNotification(Self); |
| end; |
| end; |
| procedure TDataFormatAdapter.SetEnabled(const Value: boolean); |
| begin |
| if (csLoading in ComponentState) then |
| begin |
| FEnabled := Value; |
| end else |
| if (csDesigning in ComponentState) then |
| begin |
| FEnabled := Value and Assigned(FDragDropComponent) and |
| Assigned(FDataFormatClass); |
| end else |
| if (Value) then |
| begin |
| if (Assigned(FDragDropComponent)) and (Assigned(FDataFormatClass)) and |
| (not Assigned(FDataFormat)) then |
| FDataFormat := FDataFormatClass.Create(FDragDropComponent); |
| end else |
| begin |
| if Assigned(FDataFormat) then |
| begin |
| if Assigned(FDragDropComponent) and |
| (FDragDropComponent.DataFormats.IndexOf(FDataFormat) <> -1) then |
| FDataFormat.Free; |
| FDataFormat := nil; |
| end; |
| end; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TRawClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TRawClipboardFormat.Create; |
| begin |
| // Yeah, it's a hack but blame Borland for making TObject.Create public! |
| raise Exception.CreateFmt(sBadConstructor, [ClassName]); |
| end; |
| constructor TRawClipboardFormat.CreateFormatEtc(const AFormatEtc: TFormatEtc); |
| begin |
| inherited CreateFormatEtc(AFormatEtc); |
| end; |
| procedure TRawClipboardFormat.SetClipboardFormatName(const Value: string); |
| begin |
| ClipboardFormat := RegisterClipboardFormat(PChar(Value)); |
| end; |
| function TRawClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| Result := FFormatEtc.cfFormat; |
| end; |
| function TRawClipboardFormat.Assign(Source: TCustomDataFormat): boolean; |
| begin |
| if (Source is TRawDataFormat) then |
| begin |
| Result := True; |
| end else |
| Result := inherited Assign(Source); |
| end; |
| function TRawClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean; |
| begin |
| if (Dest is TRawDataFormat) then |
| begin |
| Result := True; |
| end else |
| Result := inherited AssignTo(Dest); |
| end; |
| procedure TRawClipboardFormat.Clear; |
| begin |
| // Since TRawDataFormat performs storage for TRawDataFormat we only allow |
| // TRawDataFormat to clear. To accomplish this TRawDataFormat ignores calls to |
| // the clear method and instead introduces the ClearData method. |
| end; |
| procedure TRawClipboardFormat.ClearData; |
| begin |
| ReleaseStgMedium(FMedium); |
| FillChar(FMedium, SizeOf(FMedium), 0); |
| end; |
| function TRawClipboardFormat.HasData: boolean; |
| begin |
| Result := (FMedium.tymed <> TYMED_NULL); |
| end; |
| function TRawClipboardFormat.NeedsData: boolean; |
| begin |
| Result := (FMedium.tymed = TYMED_NULL); |
| end; |
| procedure TRawClipboardFormat.CopyFromStgMedium(const AMedium: TStgMedium); |
| begin |
| CopyStgMedium(AMedium, FMedium); |
| end; |
| procedure TRawClipboardFormat.CopyToStgMedium(var AMedium: TStgMedium); |
| begin |
| CopyStgMedium(FMedium, AMedium); |
| end; |
| function TRawClipboardFormat.DoGetData(ADataObject: IDataObject; |
| const AMedium: TStgMedium): boolean; |
| begin |
| Result := CopyStgMedium(AMedium, FMedium); |
| end; |
| function TRawClipboardFormat.DoSetData(const FormatEtcIn: TFormatEtc; |
| var AMedium: TStgMedium): boolean; |
| begin |
| Result := CopyStgMedium(FMedium, AMedium); |
| end; |
| function TRawClipboardFormat.GetString: string; |
| begin |
| with TTextClipboardFormat.Create do |
| try |
| if GetDataFromMedium(nil, FMedium) then |
| Result := Text |
| else |
| Result := ''; |
| finally |
| Free; |
| end; |
| end; |
| procedure TRawClipboardFormat.SetString(const Value: string); |
| begin |
| with TTextClipboardFormat.Create do |
| try |
| Text := Value; |
| SetDataToMedium(FormatEtc, FMedium); |
| finally |
| Free; |
| end; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TRawDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure TRawDataFormat.Clear; |
| var |
| i: integer; |
| begin |
| Changing; |
| for i := 0 to CompatibleFormats.Count-1 do |
| TRawClipboardFormat(CompatibleFormats[i]).ClearData; |
| end; |
| function TRawDataFormat.HasData: boolean; |
| var |
| i: integer; |
| begin |
| i := 0; |
| Result := False; |
| while (not Result) and (i < CompatibleFormats.Count) do |
| begin |
| Result := TRawClipboardFormat(CompatibleFormats[i]).HasData; |
| inc(i); |
| end; |
| end; |
| function TRawDataFormat.NeedsData: boolean; |
| var |
| i: integer; |
| begin |
| i := 0; |
| Result := False; |
| while (not Result) and (i < CompatibleFormats.Count) do |
| begin |
| Result := TRawClipboardFormat(CompatibleFormats[i]).NeedsData; |
| inc(i); |
| end; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Utility functions |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure _RaiseLastWin32Error; |
| begin |
| {$ifdef VER14_PLUS} |
| RaiseLastOSError; |
| {$else} |
| RaiseLastWin32Error; |
| {$endif} |
| end; |
| function DropEffectToDragType(DropEffect: longInt; var DragType: TDragType): boolean; |
| begin |
| Result := True; |
| if ((DropEffect and DROPEFFECT_COPY) <> 0) then |
| DragType := dtCopy |
| else |
| if ((DropEffect and DROPEFFECT_MOVE) <> 0) then |
| DragType := dtMove |
| else |
| if ((DropEffect and DROPEFFECT_LINK) <> 0) then |
| DragType := dtLink |
| else |
| begin |
| DragType := dtCopy; |
| Result := False; |
| end; |
| end; |
| function DragTypesToDropEffect(DragTypes: TDragTypes): longint; |
| begin |
| Result := DROPEFFECT_NONE; |
| if (dtCopy in DragTypes) then |
| Result := Result OR DROPEFFECT_COPY; |
| if (dtMove in DragTypes) then |
| Result := Result OR DROPEFFECT_MOVE; |
| if (dtLink in DragTypes) then |
| Result := Result OR DROPEFFECT_LINK; |
| end; |
| // Replacement for the buggy DragDetect API function. |
| function DragDetectPlus(Handle: THandle; p: TPoint): boolean; |
| var |
| DragRect: TRect; |
| Msg: TMsg; |
| StartTime: DWORD; |
| OldCapture: HWND; |
| begin |
| Result := False; |
| if (not ClientToScreen(Handle, p)) then |
| exit; |
| // Calculate the drag rect. If the mouse leaves this rect while the |
| // mouse button is pressed, a drag is detected. |
| DragRect.TopLeft := p; |
| DragRect.BottomRight := p; |
| InflateRect(DragRect, GetSystemMetrics(SM_CXDRAG), GetSystemMetrics(SM_CYDRAG)); |
| StartTime := TimeGetTime; |
| // Capture the mouse so that we will receive mouse messages even after the |
| // mouse leaves the control rect. |
| OldCapture := SetCapture(Handle); |
| try |
| // Abort if we failed to capture the mouse. |
| if (GetCapture <> Handle) then |
| exit; |
| while (not Result) do |
| begin |
| // Detect if all mouse buttons are up (might mean that we missed a |
| // MW_?BUTTONUP message). |
| if (GetAsyncKeyState(VK_LBUTTON) AND $8000 = 0) and |
| (GetAsyncKeyState(VK_RBUTTON) AND $8000 = 0) then |
| break; |
| if (PeekMessage(Msg, Handle, 0,0, PM_REMOVE)) then |
| begin |
| case (Msg.message) of |
| WM_MOUSEMOVE: |
| // Mouse were moved. Check if we are still within the drag rect... |
| Result := (not PtInRect(DragRect, Msg.pt)) and |
| // ... and that the minimum time has elapsed. |
| // Note that we ignore time warp (wrap around) and that Msg.Time |
| // might be smaller than StartTime. |
| (Msg.time >= StartTime + DWORD(DragDropDragDelay)); |
| WM_RBUTTONUP, |
| WM_LBUTTONUP, |
| WM_CANCELMODE: |
| // Mouse button were released, escape were pressed or some other |
| // operation cancelled our mouse capture. |
| break; |
| WM_QUIT: |
| // Application is shutting down. Get out of here fast. |
| exit; |
| else |
| TranslateMessage(Msg); |
| DispatchMessage(Msg); |
| end; |
| end else |
| Sleep(0); |
| end; |
| finally |
| ReleaseCapture; |
| // Restore previous capture. |
| if (OldCapture <> 0) then |
| SetCapture(OldCapture); |
| end; |
| end; |
| function ClientPtToWindowPt(Handle: THandle; pt: TPoint): TPoint; |
| var |
| Rect: TRect; |
| begin |
| ClientToScreen(Handle, pt); |
| GetWindowRect(Handle, Rect); |
| Result.X := pt.X - Rect.Left; |
| Result.Y := pt.Y - Rect.Top; |
| end; |
| const |
| // Note: The definition of MK_ALT is missing from the current Delphi (D5) |
| // declarations. Hopefully Delphi 6 will fix this. |
| MK_ALT = $20; |
| function KeysToShiftStatePlus(Keys: Word): TShiftState; |
| begin |
| Result := []; |
| if (Keys and MK_SHIFT <> 0) then |
| Include(Result, ssShift); |
| if (Keys and MK_CONTROL <> 0) then |
| Include(Result, ssCtrl); |
| if (Keys and MK_LBUTTON <> 0) then |
| Include(Result, ssLeft); |
| if (Keys and MK_RBUTTON <> 0) then |
| Include(Result, ssRight); |
| if (Keys and MK_MBUTTON <> 0) then |
| Include(Result, ssMiddle); |
| if (Keys and MK_ALT <> 0) then |
| Include(Result, ssMiddle); |
| end; |
| function ShiftStateToDropEffect(Shift: TShiftState; AllowedEffects: longint; |
| Fallback: boolean): longint; |
| begin |
| // As we're only interested in ssShift & ssCtrl here, |
| // mouse button states are screened out. |
| Shift := Shift * [ssShift, ssCtrl]; |
| Result := DROPEFFECT_NONE; |
| if (Shift = [ssShift, ssCtrl]) then |
| begin |
| if (AllowedEffects AND DROPEFFECT_LINK <> 0) then |
| Result := DROPEFFECT_LINK; |
| end else |
| if (Shift = [ssCtrl]) then |
| begin |
| if (AllowedEffects AND DROPEFFECT_COPY <> 0) then |
| Result := DROPEFFECT_COPY; |
| end else |
| begin |
| if (AllowedEffects AND DROPEFFECT_MOVE <> 0) then |
| Result := DROPEFFECT_MOVE; |
| end; |
| // Fall back to defaults if the shift-states specified an |
| // unavailable drop effect. |
| if (Result = DROPEFFECT_NONE) and (Fallback) then |
| begin |
| if (AllowedEffects AND DROPEFFECT_COPY <> 0) then |
| Result := DROPEFFECT_COPY |
| else if (AllowedEffects AND DROPEFFECT_MOVE <> 0) then |
| Result := DROPEFFECT_MOVE |
| else if (AllowedEffects AND DROPEFFECT_LINK <> 0) then |
| Result := DROPEFFECT_LINK; |
| end; |
| end; |
| var |
| URLMONDLL: THandle = 0; |
| _CopyStgMedium: function(const cstgmedSrc: TStgMedium; var stgmedDest: TStgMedium): HResult; stdcall = nil; |
| function CopyStgMedium(const SrcMedium: TStgMedium; var DstMedium: TStgMedium): boolean; |
| begin |
| // Copy the medium via the URLMON CopyStgMedium function. This should be safe |
| // since this function is only called when the drag drop helper object is |
| // used and the drag drop helper object is only supported on Windows 2000 |
| // and later. |
| // URLMON.CopyStgMedium requires IE4 or later. |
| // An alternative approach would be to use OleDuplicateData, but based on a |
| // disassembly of urlmon.dll, CopyStgMedium seems to do a lot more than |
| // OleDuplicateData. |
| if (URLMONDLL = 0) then |
| begin |
| URLMONDLL := LoadLibrary('URLMON.DLL'); |
| if (URLMONDLL <> 0) then |
| @_CopyStgMedium := GetProcAddress(URLMONDLL, 'CopyStgMedium'); |
| end; |
| if (@_CopyStgMedium = nil) then |
| raise Exception.Create(sNoCopyStgMedium); |
| Result := (_CopyStgMedium(SrcMedium, DstMedium) = S_OK); |
| end; |
| function GetClipboardFormatNameStr(Value: TClipFormat): string; |
| var |
| len: integer; |
| begin |
| Setlength(Result, 255); |
| len := GetClipboardFormatName(Value, PChar(Result), 255); |
| SetLength(Result, len); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Initialization/Finalization |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| initialization |
| OleInitialize(nil); |
| ShGetMalloc(ShellMalloc); |
| GetClipboardFormatNameStr(0); |
| finalization |
| if (FDataFormatMap <> nil) then |
| begin |
| FDataFormatMap.Free; |
| FDataFormatMap := nil; |
| end; |
| if (FDataFormatClasses <> nil) then |
| begin |
| FDataFormatClasses.Free; |
| FDataFormatClasses := nil; |
| end; |
| ShellMalloc := nil; |
| OleUninitialize; |
| end. |
| /trunk/VCL_DRAGDROP/DragDropC3.bpk |
|---|
| 0,0 → 1,179 |
| # --------------------------------------------------------------------------- |
| !if !$d(BCB) |
| BCB = $(MAKEDIR)\.. |
| !endif |
| # --------------------------------------------------------------------------- |
| # IDE SECTION |
| # --------------------------------------------------------------------------- |
| # The following section of the project makefile is managed by the BCB IDE. |
| # It is recommended to use the IDE to change any of the values in this |
| # section. |
| # --------------------------------------------------------------------------- |
| VERSION = BCB.03 |
| # --------------------------------------------------------------------------- |
| PROJECT = DragDropC3.bpl |
| OBJFILES = DropSource.obj DropURLTarget.obj DropBMPTarget.obj DropPIDLSource.obj \ |
| DropPIDLTarget.obj DropTarget.obj DropURLSource.obj DropBMPSource.obj \ |
| DragDropC3.obj |
| RESFILES = dragdropC3.res DropSource.dcr DropURLTarget.dcr DropBMPTarget.dcr \ |
| DropPIDLSource.dcr DropPIDLTarget.dcr DropTarget.dcr DropURLSource.dcr \ |
| DropBMPSource.dcr |
| DEFFILE = |
| RESDEPEN = $(RESFILES) |
| LIBFILES = |
| LIBRARIES = |
| SPARELIBS = VCL35.lib |
| PACKAGES = vcl35.bpi |
| # --------------------------------------------------------------------------- |
| PATHCPP = .; |
| PATHASM = .; |
| PATHPAS = .; |
| PATHRC = .; |
| DEBUGLIBPATH = $(BCB)\lib\debug |
| RELEASELIBPATH = $(BCB)\lib\release |
| # --------------------------------------------------------------------------- |
| CFLAG1 = -Od -Hc -w -Ve -r- -k -y -v -vi- -c -b- -w-par -w-inl -Vx |
| CFLAG2 = -DUSEPACKAGES -I$(BCB)\include;$(BCB)\include\vcl -H=$(BCB)\lib\vcl35.csm |
| CFLAG3 = -Tkh30000 |
| PFLAGS = -DUSEPACKAGES -U$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ |
| -I$(BCB)\include;$(BCB)\include\vcl -H -W -$Y -$W -v -JPHN -M |
| RFLAGS = -DUSEPACKAGES -i$(BCB)\include;$(BCB)\include\vcl |
| AFLAGS = /i$(BCB)\include /i$(BCB)\include\vcl /dUSEPACKAGES /mx /w2 /zd |
| LFLAGS = -L$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) -D"COM Drag/Drop" -aa -Tpp -x -Gn \ |
| -Gl -Gi |
| IFLAGS = |
| # --------------------------------------------------------------------------- |
| ALLOBJ = c0pkg32.obj $(PACKAGES) sysinit.obj $(OBJFILES) |
| ALLRES = $(RESFILES) |
| ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mt.lib |
| # --------------------------------------------------------------------------- |
| !ifdef IDEOPTIONS |
| [Version Info] |
| IncludeVerInfo=1 |
| AutoIncBuild=1 |
| MajorVer=3 |
| MinorVer=4 |
| Release=1 |
| Build=5 |
| Debug=0 |
| PreRelease=0 |
| Special=0 |
| Private=0 |
| DLL=1 |
| Locale=1030 |
| CodePage=1252 |
| [Version Info Keys] |
| CompanyName= |
| FileDescription= |
| FileVersion=3.4.1.5 |
| InternalName= |
| LegalCopyright= |
| LegalTrademarks= |
| OriginalFilename= |
| ProductName= |
| ProductVersion=1.0.0.0 |
| Comments=Freeware. |
| [HistoryLists\hlIncludePath] |
| Count=1 |
| Item0=$(BCB)\include;$(BCB)\include\vcl |
| [HistoryLists\hlLibraryPath] |
| Count=1 |
| Item0=$(BCB)\lib\obj;$(BCB)\lib |
| [HistoryLists\hlDebugSourcePath] |
| Count=1 |
| Item0=$(BCB)\source\vcl |
| [HistoryLists\hlConditionals] |
| Count=1 |
| Item0=USEPACKAGES |
| [Debugging] |
| DebugSourceDirs=$(BCB)\source\vcl |
| [Parameters] |
| RunParams= |
| HostApplication= |
| !endif |
| # --------------------------------------------------------------------------- |
| # MAKE SECTION |
| # --------------------------------------------------------------------------- |
| # This section of the project file is not used by the BCB IDE. It is for |
| # the benefit of building from the command-line using the MAKE utility. |
| # --------------------------------------------------------------------------- |
| .autodepend |
| # --------------------------------------------------------------------------- |
| !if !$d(BCC32) |
| BCC32 = bcc32 |
| !endif |
| !if !$d(DCC32) |
| DCC32 = dcc32 |
| !endif |
| !if !$d(TASM32) |
| TASM32 = tasm32 |
| !endif |
| !if !$d(LINKER) |
| LINKER = ilink32 |
| !endif |
| !if !$d(BRCC32) |
| BRCC32 = brcc32 |
| !endif |
| # --------------------------------------------------------------------------- |
| !if $d(PATHCPP) |
| .PATH.CPP = $(PATHCPP) |
| .PATH.C = $(PATHCPP) |
| !endif |
| !if $d(PATHPAS) |
| .PATH.PAS = $(PATHPAS) |
| !endif |
| !if $d(PATHASM) |
| .PATH.ASM = $(PATHASM) |
| !endif |
| !if $d(PATHRC) |
| .PATH.RC = $(PATHRC) |
| !endif |
| # --------------------------------------------------------------------------- |
| $(PROJECT): $(OBJFILES) $(RESDEPEN) $(DEFFILE) |
| $(BCB)\BIN\$(LINKER) @&&! |
| $(LFLAGS) + |
| $(ALLOBJ), + |
| $(PROJECT),, + |
| $(ALLLIB), + |
| $(DEFFILE), + |
| $(ALLRES) |
| ! |
| # --------------------------------------------------------------------------- |
| .pas.hpp: |
| $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } |
| .pas.obj: |
| $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } |
| .cpp.obj: |
| $(BCB)\BIN\$(BCC32) $(CFLAG1) $(CFLAG2) $(CFLAG3) -n$(@D) {$< } |
| .c.obj: |
| $(BCB)\BIN\$(BCC32) $(CFLAG1) $(CFLAG2) $(CFLAG3) -n$(@D) {$< } |
| .asm.obj: |
| $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ |
| .rc.res: |
| $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< |
| # --------------------------------------------------------------------------- |
| /trunk/VCL_DRAGDROP/DragDropC3.cpp |
|---|
| 0,0 → 1,31 |
| //--------------------------------------------------------------------------- |
| #include <vcl.h> |
| #pragma hdrstop |
| USERES("dragdropC3.res"); |
| USEPACKAGE("vcl35.bpi"); |
| USEUNIT("DropSource.pas"); |
| USERES("DropSource.dcr"); |
| USEUNIT("DropURLTarget.pas"); |
| USERES("DropURLTarget.dcr"); |
| USEUNIT("DropBMPTarget.pas"); |
| USERES("DropBMPTarget.dcr"); |
| USEUNIT("DropPIDLSource.pas"); |
| USERES("DropPIDLSource.dcr"); |
| USEUNIT("DropPIDLTarget.pas"); |
| USERES("DropPIDLTarget.dcr"); |
| USEUNIT("DropTarget.pas"); |
| USERES("DropTarget.dcr"); |
| USEUNIT("DropURLSource.pas"); |
| USERES("DropURLSource.dcr"); |
| USEUNIT("DropBMPSource.pas"); |
| USERES("DropBMPSource.dcr"); |
| //--------------------------------------------------------------------------- |
| #pragma package(smart_init) |
| //--------------------------------------------------------------------------- |
| // Package source. |
| //--------------------------------------------------------------------------- |
| int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) |
| { |
| return 1; |
| } |
| //--------------------------------------------------------------------------- |
| /trunk/VCL_DRAGDROP/DragDropC4.bpk |
|---|
| 0,0 → 1,125 |
| <?xml version='1.0' encoding='utf-8' ?> |
| <!-- C++Builder XML Project --> |
| <PROJECT> |
| <MACROS> |
| <VERSION value="BCB.05.03"/> |
| <PROJECT value="DragDropC4.bpl"/> |
| <OBJFILES value="DragDrop.obj DragDropFile.obj DragDropFormats.obj DragDropGraphics.obj |
| DragDropPIDL.obj DragDropText.obj DragDropURL.obj DropMultiTarget.obj |
| DropSource.obj DropTarget.obj DragDropC4.obj"/> |
| <RESFILES value="dragdropC4.res DragDropFile.dcr DragDropGraphics.dcr DragDropPIDL.dcr |
| DragDropText.dcr DragDropURL.dcr DropMultiTarget.dcr DropSource.dcr |
| DropTarget.dcr"/> |
| <IDLFILES value=""/> |
| <IDLGENFILES value=""/> |
| <DEFFILE value=""/> |
| <RESDEPEN value="$(RESFILES)"/> |
| <LIBFILES value=""/> |
| <LIBRARIES value="DCLUSR50.lib nmfast50.lib tee50.lib teedb50.lib teeui50.lib vcldbx50.lib |
| ibsmp50.lib vclbde50.lib vcldb50.lib qrpt50.lib bcbsmp50.lib vcljpg50.lib |
| vclx50.lib"/> |
| <SPARELIBS value="vcl50.lib vclx50.lib vcljpg50.lib bcbsmp50.lib qrpt50.lib vcldb50.lib |
| vclbde50.lib ibsmp50.lib vcldbx50.lib teeui50.lib teedb50.lib tee50.lib |
| nmfast50.lib DCLUSR50.lib"/> |
| <PACKAGES value="vcl50.bpi"/> |
| <PATHCPP value=".;"/> |
| <PATHPAS value=".;"/> |
| <PATHRC value=".;"/> |
| <PATHASM value=".;"/> |
| <DEBUGLIBPATH value="$(BCB)\lib\debug"/> |
| <RELEASELIBPATH value="$(BCB)\lib\release"/> |
| <LINKER value="ilink32"/> |
| <USERDEFINES value=""/> |
| <SYSDEFINES value="NO_STRICT;USEPACKAGES"/> |
| <MAINSOURCE value="DragDropC4.cpp"/> |
| <INCLUDEPATH value="$(BCB)\include;$(BCB)\include\vcl"/> |
| <LIBPATH value="$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib"/> |
| <WARNINGS value="-w-par -w-8027 -w-8026"/> |
| </MACROS> |
| <OPTIONS> |
| <IDLCFLAGS value="-src_suffixcpp -I$(BCB)\include -I$(BCB)\include\vcl"/> |
| <CFLAG1 value="-Od -H=d:\DEVELO~1\rampage\lib\vcl50.csm -Hc -Vx -Ve -Tkh30000 -X- -r- -a8 |
| -b- -k -y -v -vi- -c -tWM"/> |
| <PFLAGS value="-$YD -$W -v -M -JPHNE"/> |
| <RFLAGS value=""/> |
| <AFLAGS value="/mx /w2 /zd"/> |
| <LFLAGS value="-D"Drag and Drop Component Suite" -aa -Tpp -x -Gn -Gl -Gi"/> |
| </OPTIONS> |
| <LINKER> |
| <ALLOBJ value="c0pkg32.obj $(PACKAGES) sysinit.obj $(OBJFILES)"/> |
| <ALLRES value="$(RESFILES)"/> |
| <ALLLIB value="$(LIBFILES) $(LIBRARIES) import32.lib cp32mt.lib"/> |
| </LINKER> |
| <IDEOPTIONS> |
| [Version Info] |
| IncludeVerInfo=1 |
| AutoIncBuild=1 |
| MajorVer=4 |
| MinorVer=0 |
| Release=3 |
| Build=12 |
| Debug=0 |
| PreRelease=0 |
| Special=0 |
| Private=0 |
| DLL=1 |
| Locale=1030 |
| CodePage=1252 |
| [Version Info Keys] |
| CompanyName=Johnson & Melander |
| FileDescription=Drag and Drop Component Suite |
| FileVersion=4.0.3.12 |
| InternalName=DragDrop |
| LegalCopyright=Copyright © 1997-2000, Johnson & Melander |
| LegalTrademarks= |
| OriginalFilename=DragDropC4 |
| ProductName=DragDrop |
| ProductVersion=4.0.0.0 |
| Comments=Freeware. |
| mailto=anders@melander.dk |
| URL=http://www.melander.dk |
| [HistoryLists\hlIncludePath] |
| Count=1 |
| Item0=$(BCB)\include;$(BCB)\include\vcl |
| [HistoryLists\hlLibraryPath] |
| Count=2 |
| Item0=$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib |
| Item1=$(BCB)\lib\obj;$(BCB)\lib |
| [HistoryLists\hlDebugSourcePath] |
| Count=1 |
| Item0=$(BCB)\source\vcl |
| [HistoryLists\hlConditionals] |
| Count=1 |
| Item0=USEPACKAGES |
| [Debugging] |
| DebugSourceDirs=$(BCB)\source\vcl |
| [Parameters] |
| RunParams= |
| HostApplication= |
| RemoteHost= |
| RemotePath= |
| RemoteDebug=0 |
| [Compiler] |
| ShowInfoMsgs=0 |
| LinkDebugVcl=0 |
| LinkCGLIB=0 |
| [CORBA] |
| AddServerUnit=1 |
| AddClientUnit=1 |
| PrecompiledHeaders=1 |
| [Language] |
| ActiveLang= |
| ProjectLang= |
| RootDir= |
| </IDEOPTIONS> |
| </PROJECT> |
| /trunk/VCL_DRAGDROP/DragDropC4.cpp |
|---|
| 0,0 → 1,33 |
| //--------------------------------------------------------------------------- |
| #include <vcl.h> |
| #pragma hdrstop |
| USERES("dragdropC4.res"); |
| USEUNIT("DragDrop.pas"); |
| USEUNIT("DragDropFile.pas"); |
| USERES("DragDropFile.dcr"); |
| USEUNIT("DragDropFormats.pas"); |
| USEUNIT("DragDropGraphics.pas"); |
| USERES("DragDropGraphics.dcr"); |
| USEUNIT("DragDropPIDL.pas"); |
| USERES("DragDropPIDL.dcr"); |
| USEUNIT("DragDropText.pas"); |
| USERES("DragDropText.dcr"); |
| USEUNIT("DragDropURL.pas"); |
| USERES("DragDropURL.dcr"); |
| USEUNIT("DropMultiTarget.pas"); |
| USERES("DropMultiTarget.dcr"); |
| USEUNIT("DropSource.pas"); |
| USERES("DropSource.dcr"); |
| USEUNIT("DropTarget.pas"); |
| USERES("DropTarget.dcr"); |
| USEPACKAGE("vcl50.bpi"); |
| //--------------------------------------------------------------------------- |
| #pragma package(smart_init) |
| //--------------------------------------------------------------------------- |
| // Package source. |
| //--------------------------------------------------------------------------- |
| int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) |
| { |
| return 1; |
| } |
| //--------------------------------------------------------------------------- |
| /trunk/VCL_DRAGDROP/DragDropC5.bpk |
|---|
| 0,0 → 1,123 |
| <?xml version='1.0' encoding='utf-8' ?> |
| <!-- C++Builder XML Project --> |
| <PROJECT> |
| <MACROS> |
| <VERSION value="BCB.05.03"/> |
| <PROJECT value="DragDropC5.bpl"/> |
| <OBJFILES value="DragDrop.obj DragDropFile.obj DragDropFormats.obj DragDropGraphics.obj |
| DragDropPIDL.obj DragDropText.obj DropSource.obj DropTarget.obj |
| DragDropInternet.obj DropComboTarget.obj DragDropHandler.obj DragDropC5.obj"/> |
| <RESFILES value="DragDropFile.dcr DragDropGraphics.dcr DragDropPIDL.dcr DragDropText.dcr |
| DropSource.dcr DropTarget.dcr DragDropInternet.dcr DropComboTarget.dcr |
| DragDropHandler.dcr"/> |
| <IDLFILES value=""/> |
| <IDLGENFILES value=""/> |
| <DEFFILE value=""/> |
| <RESDEPEN value="$(RESFILES)"/> |
| <LIBFILES value=""/> |
| <LIBRARIES value=""/> |
| <SPARELIBS value="Vcl50.lib"/> |
| <PACKAGES value="Vcl50.bpi"/> |
| <PATHCPP value=".;"/> |
| <PATHPAS value=".;"/> |
| <PATHRC value=".;"/> |
| <PATHASM value=".;"/> |
| <DEBUGLIBPATH value="$(BCB)\lib\debug"/> |
| <RELEASELIBPATH value="$(BCB)\lib\release"/> |
| <LINKER value="ilink32"/> |
| <USERDEFINES value="NO_WIN32_LEAN_AND_MEAN"/> |
| <SYSDEFINES value="NO_STRICT;USEPACKAGES"/> |
| <MAINSOURCE value="DragDropC5.cpp"/> |
| <INCLUDEPATH value="$(BCB)\include;$(BCB)\include\vcl"/> |
| <LIBPATH value="$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib"/> |
| <WARNINGS value="-w-par -w-8027 -w-8026"/> |
| </MACROS> |
| <OPTIONS> |
| <IDLCFLAGS value="-I$(BCB)\include -I$(BCB)\include\vcl -src_suffixcpp |
| -DNO_WIN32_LEAN_AND_MEAN"/> |
| <CFLAG1 value="-Od -H=d:\DEVELO~1\rampage\lib\vcl50.csm -Hc -Vx -Ve -Tkh30000 -X- -r- -a8 |
| -b- -k -y -v -vi- -c -tWM"/> |
| <PFLAGS value="-$YD -$W -$R -$Q -v -M -JPHNE"/> |
| <RFLAGS value=""/> |
| <AFLAGS value="/mx /w2 /zd"/> |
| <LFLAGS value="-D"Drag and Drop Component Suite" -aa -Tpp -Gpd -x -Gn -Gl -Gi"/> |
| </OPTIONS> |
| <LINKER> |
| <ALLOBJ value="c0pkg32.obj $(PACKAGES) sysinit.obj $(OBJFILES)"/> |
| <ALLRES value="$(RESFILES)"/> |
| <ALLLIB value="$(LIBFILES) $(LIBRARIES) import32.lib cp32mt.lib"/> |
| </LINKER> |
| <IDEOPTIONS> |
| [Version Info] |
| IncludeVerInfo=0 |
| AutoIncBuild=1 |
| MajorVer=4 |
| MinorVer=0 |
| Release=3 |
| Build=13 |
| Debug=0 |
| PreRelease=0 |
| Special=0 |
| Private=0 |
| DLL=1 |
| Locale=1030 |
| CodePage=1252 |
| [Version Info Keys] |
| CompanyName=Johnson & Melander |
| FileDescription=Drag and Drop Component Suite |
| FileVersion=4.0.3.13 |
| InternalName=DragDrop |
| LegalCopyright=Copyright © 1997-2000, Johnson & Melander |
| LegalTrademarks= |
| OriginalFilename=DragDropC4 |
| ProductName=DragDrop |
| ProductVersion=4.0.0.0 |
| Comments=Freeware. |
| mailto=anders@melander.dk |
| URL=http://www.melander.dk |
| [HistoryLists\hlIncludePath] |
| Count=1 |
| Item0=$(BCB)\include;$(BCB)\include\vcl |
| [HistoryLists\hlLibraryPath] |
| Count=2 |
| Item0=$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib |
| Item1=$(BCB)\lib\obj;$(BCB)\lib |
| [HistoryLists\hlDebugSourcePath] |
| Count=1 |
| Item0=$(BCB)\source\vcl |
| [HistoryLists\hlConditionals] |
| Count=2 |
| Item0=NO_WIN32_LEAN_AND_MEAN |
| Item1=USEPACKAGES |
| [Debugging] |
| DebugSourceDirs=$(BCB)\source\vcl |
| [Parameters] |
| RunParams= |
| HostApplication= |
| RemoteHost= |
| RemotePath= |
| RemoteDebug=0 |
| [Compiler] |
| ShowInfoMsgs=1 |
| LinkDebugVcl=0 |
| LinkCGLIB=0 |
| [CORBA] |
| AddServerUnit=1 |
| AddClientUnit=1 |
| PrecompiledHeaders=1 |
| [Language] |
| ActiveLang= |
| ProjectLang= |
| RootDir= |
| </IDEOPTIONS> |
| </PROJECT> |
| /trunk/VCL_DRAGDROP/DragDropC5.cpp |
|---|
| 0,0 → 1,34 |
| //--------------------------------------------------------------------------- |
| #include <vcl.h> |
| #pragma hdrstop |
| USEUNIT("DragDrop.pas"); |
| USEUNIT("DragDropFile.pas"); |
| USERES("DragDropFile.dcr"); |
| USEUNIT("DragDropFormats.pas"); |
| USEUNIT("DragDropGraphics.pas"); |
| USERES("DragDropGraphics.dcr"); |
| USEUNIT("DragDropPIDL.pas"); |
| USERES("DragDropPIDL.dcr"); |
| USEUNIT("DragDropText.pas"); |
| USERES("DragDropText.dcr"); |
| USEUNIT("DropSource.pas"); |
| USERES("DropSource.dcr"); |
| USEUNIT("DropTarget.pas"); |
| USERES("DropTarget.dcr"); |
| USEUNIT("DragDropInternet.pas"); |
| USERES("DragDropInternet.dcr"); |
| USEPACKAGE("Vcl50.bpi"); |
| USEUNIT("DropComboTarget.pas"); |
| USERES("DropComboTarget.dcr"); |
| USEUNIT("DragDropHandler.pas"); |
| USERES("DragDropHandler.dcr"); |
| //--------------------------------------------------------------------------- |
| #pragma package(smart_init) |
| //--------------------------------------------------------------------------- |
| // Package source. |
| //--------------------------------------------------------------------------- |
| int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) |
| { |
| return 1; |
| } |
| //--------------------------------------------------------------------------- |
| /trunk/VCL_DRAGDROP/DragDropComObj.pas |
|---|
| 0,0 → 1,344 |
| unit DragDropComObj; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite. |
| // Module: DragDropComObj |
| // Description: Implements misc COM support classes. |
| // Version: 4.0 |
| // Date: 18-MAY-2001 |
| // Target: Win32, Delphi 5-6 |
| // Authors: Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2001 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| ComObj, |
| Classes, |
| ActiveX; |
| {$include DragDrop.inc} |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TVCLComObject |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Based on TVCLAutoObject. |
| //////////////////////////////////////////////////////////////////////////////// |
| type |
| TVCLComObject = class(TComObject, IVCLComObject, IUnknown) |
| private |
| FComponent: TComponent; |
| FOwnsComponent: Boolean; |
| protected |
| // IVCLComObject implementation |
| procedure FreeOnRelease; |
| function Invoke(DispID: Integer; const IID: TGUID; |
| LocaleID: Integer; Flags: Word; var Params; |
| VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall; |
| function GetIDsOfNames(const IID: TGUID; Names: Pointer; |
| NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall; |
| function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall; |
| function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall; |
| public |
| // TODO : For now, please ignore linker warning about TVCLComObject.Create |
| constructor Create(Factory: TComObjectFactory; Component: TComponent); |
| destructor Destroy; override; |
| procedure Initialize; override; |
| function ObjQueryInterface(const IID: TGUID; out Obj): HResult; override; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TVCLComObjectFactory |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Class factory for component based COM classes. |
| // Does not require a type library. |
| // Based on TComponentFactory and TComObjectFactory. |
| //////////////////////////////////////////////////////////////////////////////// |
| type |
| TVCLComObjectFactory = class(TComObjectFactory, IClassFactory) |
| private |
| protected |
| function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID; |
| out Obj): HResult; stdcall; |
| public |
| constructor Create(ComServer: TComServerObject; ComponentClass: TComponentClass; |
| const ClassID: TGUID; const ClassName, Description: string; |
| Instancing: TClassInstancing); |
| function CreateComObject(const Controller: IUnknown): TComObject; override; |
| procedure UpdateRegistry(Register: Boolean); override; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TShellExtFactory |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Class factory for component based COM classes. |
| // Specialized for Shell Extensions. |
| //////////////////////////////////////////////////////////////////////////////// |
| TShellExtFactory = class(TVCLComObjectFactory) |
| private |
| FFileExtension: string; |
| FFileClass: string; |
| protected |
| public |
| constructor Create(ComServer: TComServerObject; ComponentClass: TComponentClass; |
| const ClassID: TGUID; const ClassName, Description, AFileClass, |
| AFileExtension: string; Instancing: TClassInstancing); |
| procedure UpdateRegistry(Register: Boolean); override; |
| property FileClass: string read FFileClass write FFileClass; |
| property FileExtension: string read FFileExtension write FFileExtension; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // IMPLEMENTATION |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| implementation |
| uses |
| Windows; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TVCLComObject |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TVCLComObject.Create(Factory: TComObjectFactory; |
| Component: TComponent); |
| begin |
| FComponent := Component; |
| CreateFromFactory(Factory, nil); |
| end; |
| destructor TVCLComObject.Destroy; |
| begin |
| if FComponent <> nil then |
| begin |
| FComponent.VCLComObject := nil; |
| if FOwnsComponent then |
| FComponent.Free; |
| end; |
| inherited Destroy; |
| end; |
| procedure TVCLComObject.FreeOnRelease; |
| begin |
| FOwnsComponent := True; |
| end; |
| function TVCLComObject.GetIDsOfNames(const IID: TGUID; Names: Pointer; |
| NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; |
| begin |
| Result := E_NOTIMPL; |
| end; |
| function TVCLComObject.GetTypeInfo(Index, LocaleID: Integer; |
| out TypeInfo): HResult; |
| begin |
| Pointer(TypeInfo) := nil; |
| Result := E_NOTIMPL; |
| end; |
| function TVCLComObject.GetTypeInfoCount(out Count: Integer): HResult; |
| begin |
| Count := 0; |
| Result := E_NOTIMPL; |
| end; |
| procedure TVCLComObject.Initialize; |
| begin |
| inherited Initialize; |
| if FComponent = nil then |
| begin |
| FComponent := TComponentClass(Factory.ComClass).Create(nil); |
| FOwnsComponent := True; |
| end; |
| FComponent.VCLComObject := Pointer(IVCLComObject(Self)); |
| end; |
| function TVCLComObject.Invoke(DispID: Integer; const IID: TGUID; |
| LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, |
| ArgErr: Pointer): HResult; |
| begin |
| Result := E_NOTIMPL; |
| end; |
| function TVCLComObject.ObjQueryInterface(const IID: TGUID; |
| out Obj): HResult; |
| begin |
| Result := inherited ObjQueryInterface(IID, Obj); |
| if (Result <> 0) and (FComponent <> nil) then |
| if FComponent.GetInterface(IID, Obj) then |
| Result := 0; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TApartmentThread |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Copied from VCLCom unit. |
| //////////////////////////////////////////////////////////////////////////////// |
| type |
| TApartmentThread = class(TThread) |
| private |
| FFactory: IClassFactory2; |
| FUnkOuter: IUnknown; |
| FIID: TGuid; |
| FSemaphore: THandle; |
| FStream: Pointer; |
| FCreateResult: HResult; |
| protected |
| procedure Execute; override; |
| public |
| constructor Create(Factory: IClassFactory2; UnkOuter: IUnknown; IID: TGuid); |
| destructor Destroy; override; |
| property Semaphore: THandle read FSemaphore; |
| property CreateResult: HResult read FCreateResult; |
| property ObjStream: Pointer read FStream; |
| end; |
| constructor TApartmentThread.Create(Factory: IClassFactory2; |
| UnkOuter: IUnknown; IID: TGuid); |
| begin |
| FFactory := Factory; |
| FUnkOuter := UnkOuter; |
| FIID := IID; |
| FSemaphore := CreateSemaphore(nil, 0, 1, nil); |
| FreeOnTerminate := True; |
| inherited Create(False); |
| end; |
| destructor TApartmentThread.Destroy; |
| begin |
| CloseHandle(FSemaphore); |
| inherited Destroy; |
| end; |
| procedure TApartmentThread.Execute; |
| var |
| msg: TMsg; |
| Unk: IUnknown; |
| begin |
| try |
| CoInitialize(nil); |
| try |
| FCreateResult := FFactory.CreateInstanceLic(FUnkOuter, nil, FIID, '', Unk); |
| FUnkOuter := nil; |
| FFactory := nil; |
| if FCreateResult = S_OK then |
| CoMarshalInterThreadInterfaceInStream(FIID, Unk, IStream(FStream)); |
| ReleaseSemaphore(FSemaphore, 1, nil); |
| if FCreateResult = S_OK then |
| while GetMessage(msg, 0, 0, 0) do |
| begin |
| DispatchMessage(msg); |
| Unk._AddRef; |
| if Unk._Release = 1 then break; |
| end; |
| finally |
| Unk := nil; |
| CoUninitialize; |
| end; |
| except |
| { No exceptions should go unhandled } |
| end; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TVCLComObjectFactory |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TVCLComObjectFactory.Create(ComServer: TComServerObject; |
| ComponentClass: TComponentClass; const ClassID: TGUID; const ClassName, |
| Description: string; Instancing: TClassInstancing); |
| begin |
| inherited Create(ComServer, TComClass(ComponentClass), ClassID, ClassName, |
| Description, Instancing, tmApartment); |
| end; |
| function TVCLComObjectFactory.CreateComObject(const Controller: IUnknown): TComObject; |
| begin |
| Result := TVCLComObject.CreateFromFactory(Self, Controller); |
| end; |
| function TVCLComObjectFactory.CreateInstance(const UnkOuter: IUnknown; |
| const IID: TGUID; out Obj): HResult; |
| begin |
| if not IsLibrary then |
| begin |
| LockServer(True); |
| try |
| with TApartmentThread.Create(Self, UnkOuter, IID) do |
| begin |
| if WaitForSingleObject(Semaphore, INFINITE) = WAIT_OBJECT_0 then |
| begin |
| Result := CreateResult; |
| if Result <> S_OK then Exit; |
| Result := CoGetInterfaceAndReleaseStream(IStream(ObjStream), IID, Obj); |
| end else |
| Result := E_FAIL |
| end; |
| finally |
| LockServer(False); |
| end; |
| end else |
| Result := inherited CreateInstance(UnkOuter, IID, Obj); |
| end; |
| type |
| TComponentProtectedAccess = class(TComponent); |
| TComponentProtectedAccessClass = class of TComponentProtectedAccess; |
| procedure TVCLComObjectFactory.UpdateRegistry(Register: Boolean); |
| begin |
| if Register then |
| inherited UpdateRegistry(Register); |
| TComponentProtectedAccessClass(ComClass).UpdateRegistry(Register, |
| GUIDToString(ClassID), ProgID); |
| if not Register then |
| inherited UpdateRegistry(Register); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TShellExtFactory |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TShellExtFactory.Create(ComServer: TComServerObject; |
| ComponentClass: TComponentClass; const ClassID: TGUID; const ClassName, |
| Description, AFileClass, AFileExtension: string; Instancing: TClassInstancing); |
| begin |
| inherited Create(ComServer, ComponentClass, ClassID, ClassName, |
| Description, Instancing); |
| FFileClass := AFileClass; |
| FFileExtension := AFileExtension; |
| end; |
| procedure TShellExtFactory.UpdateRegistry(Register: Boolean); |
| begin |
| if Register then |
| begin |
| inherited UpdateRegistry(Register); |
| if (FileExtension <> '') then |
| CreateRegKey(FileExtension, '', FileClass); |
| end else |
| begin |
| if (FileExtension <> '') then |
| RegDeleteKey(HKEY_CLASSES_ROOT, PChar(FileExtension)); |
| inherited UpdateRegistry(Register); |
| end; |
| end; |
| end. |
| /trunk/VCL_DRAGDROP/DragDropContext.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DragDropContext.pas |
|---|
| 0,0 → 1,358 |
| unit DragDropContext; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite. |
| // Module: DragDropContext |
| // Description: Implements Context Menu Handler Shell Extensions. |
| // Version: 4.0 |
| // Date: 18-MAY-2001 |
| // Target: Win32, Delphi 5-6 |
| // Authors: Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2001 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DragDrop, |
| DragDropComObj, |
| Menus, |
| ShlObj, |
| ActiveX, |
| Windows, |
| Classes; |
| {$include DragDrop.inc} |
| type |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropContextMenu |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Partially based on Borland's ShellExt demo. |
| //////////////////////////////////////////////////////////////////////////////// |
| // A typical shell context menu handler session goes like this: |
| // 1. User selects one or more files and right clicks on them. |
| // The files must of a file type which has a context menu handler registered. |
| // 2. The shell loads the context menu handler module. |
| // 3. The shell instantiates the registered context menu handler object as an |
| // in-process COM server. |
| // 4. The IShellExtInit.Initialize method is called with a data object which |
| // contains the dragged data. |
| // 5. The IContextMenu.QueryContextMenu method is called to populate the popup |
| // menu. |
| // TDropContextMenu uses the PopupMenu property to populate the shell context |
| // menu. |
| // 6. If the user chooses one of the context menu menu items we have supplied, |
| // the IContextMenu.InvokeCommand method is called. |
| // TDropContextMenu locates the corresponding TMenuItem and fires the menu |
| // items OnClick event. |
| // 7. The shell unloads the context menu handler module (usually after a few |
| // seconds). |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropContextMenu = class(TInterfacedComponent, IShellExtInit, IContextMenu) |
| private |
| FContextMenu: TPopupMenu; |
| FMenuOffset: integer; |
| FDataObject: IDataObject; |
| FOnPopup: TNotifyEvent; |
| FFiles: TStrings; |
| procedure SetContextMenu(const Value: TPopupMenu); |
| protected |
| procedure Notification(AComponent: TComponent; |
| Operation: TOperation); override; |
| { IShellExtInit } |
| function Initialize(pidlFolder: PItemIDList; lpdobj: IDataObject; |
| hKeyProgID: HKEY): HResult; stdcall; |
| { IContextMenu } |
| function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast, |
| uFlags: UINT): HResult; stdcall; |
| function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall; |
| function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; |
| pszName: LPSTR; cchMax: UINT): HResult; stdcall; |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; override; |
| property DataObject: IDataObject read FDataObject; |
| property Files: TStrings read FFiles; |
| published |
| property ContextMenu: TPopupMenu read FContextMenu write SetContextMenu; |
| property OnPopup: TNotifyEvent read FOnPopup write FOnPopup; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropContextMenuFactory |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // COM Class factory for TDropContextMenu. |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropContextMenuFactory = class(TShellExtFactory) |
| protected |
| function HandlerRegSubKey: string; virtual; |
| public |
| procedure UpdateRegistry(Register: Boolean); override; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Misc. |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // IMPLEMENTATION |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| implementation |
| uses |
| DragDropFile, |
| DragDropPIDL, |
| Registry, |
| ComObj, |
| SysUtils; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| begin |
| RegisterComponents(DragDropComponentPalettePage, [TDropContextMenu]); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Utilities |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropContextMenu |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDropContextMenu.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| FFiles := TStringList.Create; |
| end; |
| destructor TDropContextMenu.Destroy; |
| begin |
| FFiles.Free; |
| inherited Destroy; |
| end; |
| function TDropContextMenu.GetCommandString(idCmd, uType: UINT; |
| pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult; |
| var |
| ItemIndex: integer; |
| begin |
| ItemIndex := integer(idCmd); |
| // Make sure we aren't being passed an invalid argument number |
| if (ItemIndex >= 0) and (ItemIndex < FContextMenu.Items.Count) then |
| begin |
| if (uType = GCS_HELPTEXT) then |
| // return help string for menu item. |
| StrLCopy(pszName, PChar(FContextMenu.Items[ItemIndex].Hint), cchMax); |
| Result := NOERROR; |
| end else |
| Result := E_INVALIDARG; |
| end; |
| function TDropContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; |
| var |
| ItemIndex: integer; |
| begin |
| Result := E_FAIL; |
| // Make sure we are not being called by an application |
| if (FContextMenu = nil) or (HiWord(Integer(lpici.lpVerb)) <> 0) then |
| Exit; |
| ItemIndex := LoWord(lpici.lpVerb); |
| // Make sure we aren't being passed an invalid argument number |
| if (ItemIndex < 0) or (ItemIndex >= FContextMenu.Items.Count) then |
| begin |
| Result := E_INVALIDARG; |
| Exit; |
| end; |
| // Execute the menu item specified by lpici.lpVerb. |
| try |
| try |
| FContextMenu.Items[ItemIndex].Click; |
| Result := NOERROR; |
| except |
| on E: Exception do |
| begin |
| Windows.MessageBox(0, PChar(E.Message), 'Error', |
| MB_OK or MB_ICONEXCLAMATION or MB_SYSTEMMODAL); |
| Result := E_UNEXPECTED; |
| end; |
| end; |
| finally |
| FDataObject := nil; |
| FFiles.Clear; |
| end; |
| end; |
| function TDropContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, |
| idCmdLast, uFlags: UINT): HResult; |
| var |
| i: integer; |
| Last: integer; |
| Flags: UINT; |
| function IsLine(Item: TMenuItem): boolean; |
| begin |
| {$ifdef VER13_PLUS} |
| Result := Item.IsLine; |
| {$else} |
| Result := Item.Caption = '-'; |
| {$endif} |
| end; |
| begin |
| Last := 0; |
| if (FContextMenu <> nil) and (((uFlags and $0000000F) = CMF_NORMAL) or |
| ((uFlags and CMF_EXPLORE) <> 0)) then |
| begin |
| FMenuOffset := idCmdFirst; |
| for i := 0 to FContextMenu.Items.Count-1 do |
| if (FContextMenu.Items[i].Visible) then |
| begin |
| Flags := MF_STRING or MF_BYPOSITION; |
| if (not FContextMenu.Items[i].Enabled) then |
| Flags := Flags or MF_GRAYED; |
| if (IsLine(FContextMenu.Items[i])) then |
| Flags := Flags or MF_SEPARATOR; |
| // Add one menu item to context menu |
| InsertMenu(Menu, indexMenu, Flags, FMenuOffset+i, |
| PChar(FContextMenu.Items[i].Caption)); |
| inc(indexMenu); |
| Last := i+1; |
| end; |
| end else |
| FMenuOffset := 0; |
| // Return number of menu items added |
| Result := MakeResult(SEVERITY_SUCCESS, FACILITY_NULL, Last) |
| end; |
| function TDropContextMenu.Initialize(pidlFolder: PItemIDList; |
| lpdobj: IDataObject; hKeyProgID: HKEY): HResult; |
| begin |
| FFiles.Clear; |
| if (lpdobj = nil) then |
| begin |
| Result := E_INVALIDARG; |
| Exit; |
| end; |
| // Save a reference to the source data object. |
| FDataObject := lpdobj; |
| // Extract source file names and store them in a string list. |
| with TFileDataFormat.Create(nil) do |
| try |
| if GetData(DataObject) then |
| FFiles.Assign(Files); |
| finally |
| Free; |
| end; |
| if (Assigned(FOnPopup)) then |
| FOnPopup(Self); |
| Result := NOERROR; |
| end; |
| procedure TDropContextMenu.SetContextMenu(const Value: TPopupMenu); |
| begin |
| if (Value <> FContextMenu) then |
| begin |
| if (FContextMenu <> nil) then |
| FContextMenu.RemoveFreeNotification(Self); |
| FContextMenu := Value; |
| if (Value <> nil) then |
| Value.FreeNotification(Self); |
| end; |
| end; |
| procedure TDropContextMenu.Notification(AComponent: TComponent; |
| Operation: TOperation); |
| begin |
| if (Operation = opRemove) and (AComponent = FContextMenu) then |
| FContextMenu := nil; |
| inherited; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropContextMenuFactory |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TDropContextMenuFactory.HandlerRegSubKey: string; |
| begin |
| Result := 'ContextMenuHandlers'; |
| end; |
| procedure TDropContextMenuFactory.UpdateRegistry(Register: Boolean); |
| var |
| ClassIDStr: string; |
| begin |
| ClassIDStr := GUIDToString(ClassID); |
| if Register then |
| begin |
| inherited UpdateRegistry(Register); |
| CreateRegKey(FileClass+'\shellex\'+HandlerRegSubKey+'\'+ClassName, '', ClassIDStr); |
| if (Win32Platform = VER_PLATFORM_WIN32_NT) then |
| with TRegistry.Create do |
| try |
| RootKey := HKEY_LOCAL_MACHINE; |
| OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions', True); |
| OpenKey('Approved', True); |
| WriteString(ClassIDStr, Description); |
| finally |
| Free; |
| end; |
| end else |
| begin |
| if (Win32Platform = VER_PLATFORM_WIN32_NT) then |
| with TRegistry.Create do |
| try |
| RootKey := HKEY_LOCAL_MACHINE; |
| OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions', True); |
| OpenKey('Approved', True); |
| DeleteKey(ClassIDStr); |
| finally |
| Free; |
| end; |
| DeleteRegKey(FileClass+'\shellex\'+HandlerRegSubKey+'\'+ClassName); |
| inherited UpdateRegistry(Register); |
| end; |
| end; |
| end. |
| /trunk/VCL_DRAGDROP/DragDropD3.dof |
|---|
| 0,0 → 1,80 |
| [Compiler] |
| A=1 |
| B=0 |
| C=1 |
| D=1 |
| E=0 |
| F=0 |
| G=1 |
| H=1 |
| I=1 |
| J=1 |
| K=0 |
| L=1 |
| M=0 |
| N=1 |
| O=1 |
| P=1 |
| Q=1 |
| R=1 |
| S=0 |
| T=0 |
| U=0 |
| V=1 |
| W=0 |
| X=1 |
| Y=1 |
| Z=1 |
| ShowHints=1 |
| ShowWarnings=1 |
| UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; |
| [Linker] |
| MapFile=0 |
| OutputObjs=0 |
| ConsoleApp=1 |
| DebugInfo=0 |
| RemoteSymbols=0 |
| MinStackSize=16384 |
| MaxStackSize=1048576 |
| ImageBase=4194304 |
| ExeDescription=COM DragDrop components |
| [Directories] |
| OutputDir= |
| UnitOutputDir= |
| PackageDLLOutputDir= |
| PackageDCPOutputDir= |
| SearchPath= |
| Packages= |
| Conditionals= |
| DebugSourceDirs= |
| UsePackages=0 |
| [Parameters] |
| RunParams= |
| HostApplication= |
| [Version Info] |
| IncludeVerInfo=1 |
| AutoIncBuild=1 |
| MajorVer=3 |
| MinorVer=4 |
| Release=1 |
| Build=8 |
| Debug=0 |
| PreRelease=0 |
| Special=0 |
| Private=0 |
| DLL=1 |
| Locale=1033 |
| CodePage=1252 |
| [Version Info Keys] |
| CompanyName=Johnson, Melander & Wideman |
| FileDescription=COM DragDrop components |
| FileVersion=3.4.1.8 |
| InternalName=DragDrop |
| LegalCopyright=Copyright © 1997-99, Johnson, Melander & Wideman |
| LegalTrademarks= |
| OriginalFilename=DragDrop |
| ProductName=DragDrop |
| ProductVersion=1.0.0.0 |
| Comments=Freeware. |
| mailto=ajohnson@rpi.net.au ; anders@melander.dk ; graham@sdsu.edu |
| URL=http://www.melander.dk |
| /trunk/VCL_DRAGDROP/DragDropD3.dpk |
|---|
| 0,0 → 1,50 |
| package DragDropD3; |
| {$R *.RES} |
| {$R 'DropSource.dcr'} |
| {$R 'DropTarget.dcr'} |
| {$R 'DropBMPSource.dcr'} |
| {$R 'DropBMPTarget.dcr'} |
| {$R 'DropURLSource.dcr'} |
| {$R 'DropURLTarget.dcr'} |
| {$R 'DropPIDLSource.dcr'} |
| {$R 'DropPIDLTarget.dcr'} |
| {$ALIGN ON} |
| {$ASSERTIONS ON} |
| {$BOOLEVAL OFF} |
| {$DEBUGINFO ON} |
| {$EXTENDEDSYNTAX ON} |
| {$IMPORTEDDATA ON} |
| {$IOCHECKS ON} |
| {$LOCALSYMBOLS ON} |
| {$LONGSTRINGS ON} |
| {$OPENSTRINGS ON} |
| {$OPTIMIZATION ON} |
| {$OVERFLOWCHECKS ON} |
| {$RANGECHECKS ON} |
| {$REFERENCEINFO OFF} |
| {$SAFEDIVIDE OFF} |
| {$STACKFRAMES OFF} |
| {$TYPEDADDRESS OFF} |
| {$VARSTRINGCHECKS ON} |
| {$WRITEABLECONST ON} |
| {$MINENUMSIZE 1} |
| {$IMAGEBASE $00400000} |
| {$DESCRIPTION 'Drag and Drop Component Suite'} |
| {$DESIGNONLY} |
| {$IMPLICITBUILD ON} |
| requires |
| vcl30; |
| contains |
| DropSource, |
| DropTarget, |
| DropBMPSource, |
| DropBMPTarget, |
| DropURLSource, |
| DropURLTarget, |
| DropPIDLSource, |
| DropPIDLTarget; |
| end. |
| /trunk/VCL_DRAGDROP/DragDropD3.res |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DragDropD4.dof |
|---|
| 0,0 → 1,89 |
| [Compiler] |
| A=1 |
| B=0 |
| C=1 |
| D=1 |
| E=0 |
| F=0 |
| G=1 |
| H=1 |
| I=1 |
| J=1 |
| K=0 |
| L=0 |
| M=0 |
| N=1 |
| O=0 |
| P=1 |
| Q=1 |
| R=1 |
| S=0 |
| T=0 |
| U=0 |
| V=1 |
| W=0 |
| X=1 |
| Y=1 |
| Z=1 |
| ShowHints=1 |
| ShowWarnings=1 |
| UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; |
| [Linker] |
| MapFile=0 |
| OutputObjs=0 |
| ConsoleApp=1 |
| DebugInfo=0 |
| RemoteSymbols=0 |
| MinStackSize=16384 |
| MaxStackSize=1048576 |
| ImageBase=4259840 |
| ExeDescription=Drag and Drop Component Suite |
| [Directories] |
| OutputDir= |
| UnitOutputDir= |
| PackageDLLOutputDir= |
| PackageDCPOutputDir= |
| SearchPath= |
| Packages= |
| Conditionals= |
| DebugSourceDirs= |
| UsePackages=0 |
| [Parameters] |
| RunParams= |
| HostApplication= |
| [Version Info] |
| IncludeVerInfo=1 |
| AutoIncBuild=1 |
| MajorVer=4 |
| MinorVer=0 |
| Release=3 |
| Build=11 |
| Debug=0 |
| PreRelease=0 |
| Special=0 |
| Private=0 |
| DLL=1 |
| Locale=1033 |
| CodePage=1252 |
| [Version Info Keys] |
| CompanyName=Anders melander |
| FileDescription=Drag and Drop Component Suite |
| FileVersion=4.0.3.11 |
| InternalName=DragDrop |
| LegalCopyright=Copyright © 1997-2000 Angus Johnson & Anders Melander |
| LegalTrademarks= |
| OriginalFilename=DragDrop |
| ProductName=DragDrop |
| ProductVersion=1.0.0.0 |
| Comments=Freeware. |
| mailto=anders@melander.dk |
| URL=http://www.melander.dk |
| [Excluded Packages] |
| $(DELPHI)\Bin\dcltee40.bpl=Borland TeeChart Components |
| $(DELPHI)\Bin\dcldss40.bpl=Borland Decision Cube Components |
| [HistoryLists\hlDebugSourcePath] |
| Count=1 |
| Item0=$(DELPHI)\source\vcl;$(DELPHI)\source\rtl\win |
| [HistoryLists\hlUnitAliases] |
| Count=1 |
| Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; |
| /trunk/VCL_DRAGDROP/DragDropD4.dpk |
|---|
| 0,0 → 1,61 |
| package DragDropD4; |
| {$R *.RES} |
| {$R 'DragDrop.dcr'} |
| {$R 'DropSource.dcr'} |
| {$R 'DropTarget.dcr'} |
| {$R 'DragDropText.dcr'} |
| {$R 'DragDropFile.dcr'} |
| {$R 'DragDropGraphics.dcr'} |
| {$R 'DragDropPIDL.dcr'} |
| {$R 'DragDropInternet.dcr'} |
| {$R 'DropComboTarget.dcr'} |
| {$R 'DragDropHandler.dcr'} |
| {$R 'DragDropContext.dcr'} |
| {$ALIGN ON} |
| {$ASSERTIONS ON} |
| {$BOOLEVAL OFF} |
| {$DEBUGINFO ON} |
| {$EXTENDEDSYNTAX ON} |
| {$IMPORTEDDATA ON} |
| {$IOCHECKS ON} |
| {$LOCALSYMBOLS OFF} |
| {$LONGSTRINGS ON} |
| {$OPENSTRINGS ON} |
| {$OPTIMIZATION OFF} |
| {$OVERFLOWCHECKS ON} |
| {$RANGECHECKS ON} |
| {$REFERENCEINFO ON} |
| {$SAFEDIVIDE OFF} |
| {$STACKFRAMES OFF} |
| {$TYPEDADDRESS OFF} |
| {$VARSTRINGCHECKS ON} |
| {$WRITEABLECONST ON} |
| {$MINENUMSIZE 1} |
| {$IMAGEBASE $00410000} |
| {$DESCRIPTION 'Drag and Drop Component Suite'} |
| {$DESIGNONLY} |
| {$IMPLICITBUILD OFF} |
| requires |
| Vcl40; |
| contains |
| DropSource in 'DropSource.pas', |
| DropTarget in 'DropTarget.pas', |
| DragDropPIDL in 'DragDropPIDL.pas', |
| DragDropFormats in 'DragDropFormats.pas', |
| DragDropFile in 'DragDropFile.pas', |
| DragDropText in 'DragDropText.pas', |
| DragDrop in 'DragDrop.pas', |
| DragDropGraphics in 'DragDropGraphics.pas', |
| DropSource3 in 'DropSource3.pas', |
| DropFileSource3 in 'DropFileSource3.pas', |
| DragDropInternet in 'DragDropInternet.pas', |
| DragDropDesign in 'DragDropDesign.pas', |
| DropComboTarget in 'DropComboTarget.pas', |
| DragDropHandler in 'DragDropHandler.pas', |
| DragDropContext in 'DragDropContext.pas', |
| DragDropComObj in 'DragDropComObj.pas'; |
| end. |
| /trunk/VCL_DRAGDROP/DragDropD4.res |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DragDropD5.cfg |
|---|
| 0,0 → 1,36 |
| -$A+ |
| -$B- |
| -$C+ |
| -$D+ |
| -$E- |
| -$F- |
| -$G+ |
| -$H+ |
| -$I+ |
| -$J+ |
| -$K- |
| -$L- |
| -$M- |
| -$N+ |
| -$O+ |
| -$P+ |
| -$Q+ |
| -$R+ |
| -$S- |
| -$T- |
| -$U- |
| -$V+ |
| -$W- |
| -$X+ |
| -$YD |
| -$Z1 |
| -cg |
| -AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; |
| -H+ |
| -W+ |
| -M |
| -$M16384,1048576 |
| -K$00400000 |
| -LE"c:\programme\borland\delphi5\Projects\Bpl" |
| -LN"c:\programme\borland\delphi5\Projects\Bpl" |
| -Z |
| /trunk/VCL_DRAGDROP/DragDropD5.dof |
|---|
| 0,0 → 1,94 |
| [Compiler] |
| A=1 |
| B=0 |
| C=1 |
| D=1 |
| E=0 |
| F=0 |
| G=1 |
| H=1 |
| I=1 |
| J=0 |
| K=0 |
| L=0 |
| M=0 |
| N=1 |
| O=0 |
| P=1 |
| Q=1 |
| R=1 |
| S=0 |
| T=0 |
| U=0 |
| V=1 |
| W=0 |
| X=1 |
| Y=1 |
| Z=1 |
| ShowHints=1 |
| ShowWarnings=1 |
| UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; |
| [Linker] |
| MapFile=0 |
| OutputObjs=0 |
| ConsoleApp=1 |
| DebugInfo=0 |
| RemoteSymbols=0 |
| MinStackSize=16384 |
| MaxStackSize=1048576 |
| ImageBase=4259840 |
| ExeDescription=Drag and Drop Component Suite |
| [Directories] |
| OutputDir= |
| UnitOutputDir= |
| PackageDLLOutputDir= |
| PackageDCPOutputDir= |
| SearchPath=$(DELPHI)\Lib\Debug |
| Packages= |
| Conditionals= |
| DebugSourceDirs= |
| UsePackages=0 |
| [Parameters] |
| RunParams= |
| HostApplication= |
| [Language] |
| ActiveLang= |
| ProjectLang=00000406 |
| RootDir= |
| [Version Info] |
| IncludeVerInfo=1 |
| AutoIncBuild=1 |
| MajorVer=4 |
| MinorVer=0 |
| Release=3 |
| Build=19 |
| Debug=0 |
| PreRelease=0 |
| Special=0 |
| Private=0 |
| DLL=1 |
| Locale=1033 |
| CodePage=1252 |
| [Version Info Keys] |
| CompanyName=Anders Melander |
| FileDescription=Drag and Drop Component Suite |
| FileVersion=4.0.3.19 |
| InternalName=DragDrop |
| LegalCopyright=Copyright © 1997-2000 Angus Johnson & Anders Melander |
| LegalTrademarks= |
| OriginalFilename=DragDrop |
| ProductName=DragDrop |
| ProductVersion=4.0.0.0 |
| Comments=Freeware. |
| mailto=anders@melander.dk |
| URL=http://www.melander.dk |
| [Excluded Packages] |
| $(DELPHI)\Projects\Bpl\sbServerPackage.bpl=S-BOSS Server side components |
| D:\Projects\SkilteDesigner\Bin\DCDComponents.bpl=S-BOSS Designer Components |
| D:\Library\Delphi3\DragDrop\Competition\UnitOOPS\OLEDD\D5\uoolep5.bpl=UnitOOPS OLE Drag and Drop Components for Delphi 5 |
| [HistoryLists\hlUnitAliases] |
| Count=1 |
| Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; |
| [HistoryLists\hlSearchPath] |
| Count=1 |
| Item0=$(DELPHI)\Lib\Debug |
| /trunk/VCL_DRAGDROP/DragDropD5.dpk |
|---|
| 0,0 → 1,61 |
| package DragDropD5; |
| {$R *.RES} |
| {$R 'DragDrop.dcr'} |
| {$R 'DropSource.dcr'} |
| {$R 'DropTarget.dcr'} |
| {$R 'DragDropText.dcr'} |
| {$R 'DragDropFile.dcr'} |
| {$R 'DragDropGraphics.dcr'} |
| {$R 'DragDropPIDL.dcr'} |
| {$R 'DragDropInternet.dcr'} |
| {$R 'DropComboTarget.dcr'} |
| {$R 'DragDropHandler.dcr'} |
| {$R 'DragDropContext.dcr'} |
| {$R 'DropHandler.dcr'} |
| {$ALIGN ON} |
| {$ASSERTIONS ON} |
| {$BOOLEVAL OFF} |
| {$DEBUGINFO ON} |
| {$EXTENDEDSYNTAX ON} |
| {$IMPORTEDDATA ON} |
| {$IOCHECKS ON} |
| {$LOCALSYMBOLS OFF} |
| {$LONGSTRINGS ON} |
| {$OPENSTRINGS ON} |
| {$OPTIMIZATION OFF} |
| {$OVERFLOWCHECKS ON} |
| {$RANGECHECKS ON} |
| {$REFERENCEINFO ON} |
| {$SAFEDIVIDE OFF} |
| {$STACKFRAMES OFF} |
| {$TYPEDADDRESS OFF} |
| {$VARSTRINGCHECKS ON} |
| {$WRITEABLECONST OFF} |
| {$MINENUMSIZE 1} |
| {$IMAGEBASE $410000} |
| {$DESCRIPTION 'Drag and Drop Component Suite'} |
| {$DESIGNONLY} |
| {$IMPLICITBUILD OFF} |
| requires |
| Vcl50; |
| contains |
| DropSource in 'DropSource.pas', |
| DropTarget in 'DropTarget.pas', |
| DragDropPIDL in 'DragDropPIDL.pas', |
| DragDropFormats in 'DragDropFormats.pas', |
| DragDropFile in 'DragDropFile.pas', |
| DragDropText in 'DragDropText.pas', |
| DragDrop in 'DragDrop.pas', |
| DragDropGraphics in 'DragDropGraphics.pas', |
| DragDropInternet in 'DragDropInternet.pas', |
| DropComboTarget in 'DropComboTarget.pas', |
| DragDropDesign in 'DragDropDesign.pas', |
| DragDropHandler in 'DragDropHandler.pas', |
| DragDropComObj in 'DragDropComObj.pas', |
| DragDropContext in 'DragDropContext.pas', |
| DropHandler in 'DropHandler.pas'; |
| end. |
| /trunk/VCL_DRAGDROP/DragDropD5.res |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DragDropD5.~dpk |
|---|
| 0,0 → 1,49 |
| package DragDropD5; |
| {$R *.RES} |
| {$R 'DropSource.dcr'} |
| {$R 'DropTarget.dcr'} |
| {$R 'DropBMPSource.dcr'} |
| {$R 'DropBMPTarget.dcr'} |
| {$R 'DropURLSource.dcr'} |
| {$R 'DropURLTarget.dcr'} |
| {$R 'DropPIDLSource.dcr'} |
| {$R 'DropPIDLTarget.dcr'} |
| {$ALIGN ON} |
| {$ASSERTIONS ON} |
| {$BOOLEVAL OFF} |
| {$DEBUGINFO ON} |
| {$EXTENDEDSYNTAX ON} |
| {$IMPORTEDDATA ON} |
| {$IOCHECKS ON} |
| {$LOCALSYMBOLS OFF} |
| {$LONGSTRINGS ON} |
| {$OPENSTRINGS ON} |
| {$OPTIMIZATION ON} |
| {$OVERFLOWCHECKS ON} |
| {$RANGECHECKS ON} |
| {$REFERENCEINFO ON} |
| {$SAFEDIVIDE OFF} |
| {$STACKFRAMES OFF} |
| {$TYPEDADDRESS OFF} |
| {$VARSTRINGCHECKS ON} |
| {$WRITEABLECONST ON} |
| {$MINENUMSIZE 1} |
| {$IMAGEBASE $400000} |
| {$DESCRIPTION 'Drag and Drop Component Suite'} |
| {$IMPLICITBUILD OFF} |
| requires |
| Vcl50; |
| contains |
| DropSource in 'DropSource.pas', |
| DropTarget in 'DropTarget.pas', |
| DropBMPSource in 'DropBMPSource.pas', |
| DropBMPTarget in 'DropBMPTarget.pas', |
| DropURLSource in 'DropURLSource.pas', |
| DropURLTarget in 'DropURLTarget.pas', |
| DropPIDLSource in 'DropPIDLSource.pas', |
| DropPIDLTarget in 'DropPIDLTarget.pas'; |
| end. |
| /trunk/VCL_DRAGDROP/DragDropD6.cfg |
|---|
| 0,0 → 1,36 |
| -$A8 |
| -$B- |
| -$C+ |
| -$D+ |
| -$E- |
| -$F- |
| -$G+ |
| -$H+ |
| -$I+ |
| -$J+ |
| -$K- |
| -$L- |
| -$M- |
| -$N+ |
| -$O+ |
| -$P+ |
| -$Q+ |
| -$R+ |
| -$S- |
| -$T- |
| -$U- |
| -$V+ |
| -$W- |
| -$X+ |
| -$YD |
| -$Z1 |
| -cg |
| -AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; |
| -H+ |
| -W+ |
| -M |
| -$M16384,1048576 |
| -K$00400000 |
| -LE"c:\programme\borland\delphi6\Projects\Bpl" |
| -LN"c:\programme\borland\delphi6\Projects\Bpl" |
| -Z |
| /trunk/VCL_DRAGDROP/DragDropD6.dof |
|---|
| 0,0 → 1,98 |
| [FileVersion] |
| Version=6.0 |
| [Compiler] |
| A=4 |
| B=0 |
| C=1 |
| D=1 |
| E=0 |
| F=0 |
| G=0 |
| H=1 |
| I=1 |
| J=0 |
| K=0 |
| L=1 |
| M=0 |
| N=1 |
| O=0 |
| P=1 |
| Q=1 |
| R=1 |
| S=0 |
| T=1 |
| U=0 |
| V=1 |
| W=1 |
| X=1 |
| Y=1 |
| Z=1 |
| ShowHints=1 |
| ShowWarnings=1 |
| UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; |
| [Linker] |
| MapFile=0 |
| OutputObjs=0 |
| ConsoleApp=1 |
| DebugInfo=0 |
| RemoteSymbols=0 |
| MinStackSize=16384 |
| MaxStackSize=1048576 |
| ImageBase=4548489 |
| ExeDescription=Drag and Drop Component Suite |
| [Directories] |
| OutputDir= |
| UnitOutputDir= |
| PackageDLLOutputDir= |
| PackageDCPOutputDir= |
| SearchPath=$(DELPHI)\Lib\Debug |
| Packages= |
| Conditionals=DEBUG |
| DebugSourceDirs= |
| UsePackages=0 |
| [Parameters] |
| RunParams= |
| HostApplication= |
| Launcher= |
| UseLauncher=0 |
| DebugCWD= |
| [Language] |
| ActiveLang= |
| ProjectLang= |
| RootDir= |
| [Version Info] |
| IncludeVerInfo=1 |
| AutoIncBuild=1 |
| MajorVer=4 |
| MinorVer=0 |
| Release=3 |
| Build=27 |
| Debug=0 |
| PreRelease=0 |
| Special=0 |
| Private=0 |
| DLL=1 |
| Locale=1033 |
| CodePage=1252 |
| [Version Info Keys] |
| CompanyName=Anders Melander |
| FileDescription=Drag and Drop Component Suite |
| FileVersion=4.0.3.27 |
| InternalName=DragDrop |
| LegalCopyright=Copyright © 1997-2001 Anders Melander |
| LegalTrademarks= |
| OriginalFilename=DragDrop |
| ProductName=DragDrop |
| ProductVersion=4.0.0.0 |
| Comments=This is freeware. Use as you please, but please give me credit. |
| mailto=anders@melander.dk |
| URL=http://www.melander.dk |
| [HistoryLists\hlConditionals] |
| Count=1 |
| Item0=DEBUG |
| [HistoryLists\hlUnitAliases] |
| Count=1 |
| Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; |
| [HistoryLists\hlSearchPath] |
| Count=1 |
| Item0=$(DELPHI)\Lib\Debug |
| /trunk/VCL_DRAGDROP/DragDropD6.dpk |
|---|
| 0,0 → 1,61 |
| package DragDropD6; |
| {$R *.res} |
| {$R 'DragDrop.dcr'} |
| {$R 'DropSource.dcr'} |
| {$R 'DropTarget.dcr'} |
| {$R 'DragDropText.dcr'} |
| {$R 'DragDropFile.dcr'} |
| {$R 'DragDropGraphics.dcr'} |
| {$R 'DragDropPIDL.dcr'} |
| {$R 'DragDropInternet.dcr'} |
| {$R 'DropComboTarget.dcr'} |
| {$R 'DragDropHandler.dcr'} |
| {$R 'DragDropContext.dcr'} |
| {$R 'DropHandler.dcr'} |
| {$ALIGN 4} |
| {$ASSERTIONS ON} |
| {$BOOLEVAL OFF} |
| {$DEBUGINFO ON} |
| {$EXTENDEDSYNTAX ON} |
| {$IMPORTEDDATA OFF} |
| {$IOCHECKS ON} |
| {$LOCALSYMBOLS ON} |
| {$LONGSTRINGS ON} |
| {$OPENSTRINGS ON} |
| {$OPTIMIZATION OFF} |
| {$OVERFLOWCHECKS ON} |
| {$RANGECHECKS ON} |
| {$REFERENCEINFO ON} |
| {$SAFEDIVIDE OFF} |
| {$STACKFRAMES ON} |
| {$TYPEDADDRESS ON} |
| {$VARSTRINGCHECKS ON} |
| {$WRITEABLECONST OFF} |
| {$MINENUMSIZE 1} |
| {$IMAGEBASE $456789} |
| {$DESCRIPTION 'Drag and Drop Component Suite'} |
| {$DESIGNONLY} |
| {$IMPLICITBUILD OFF} |
| {$DEFINE DEBUG} |
| requires |
| Vcl; |
| contains |
| DropSource in 'DropSource.pas', |
| DropTarget in 'DropTarget.pas', |
| DragDropPIDL in 'DragDropPIDL.pas', |
| DragDropFormats in 'DragDropFormats.pas', |
| DropComboTarget in 'DropComboTarget.pas', |
| DragDropFile in 'DragDropFile.pas', |
| DragDropText in 'DragDropText.pas', |
| DragDrop in 'DragDrop.pas', |
| DragDropGraphics in 'DragDropGraphics.pas', |
| DragDropInternet in 'DragDropInternet.pas', |
| DragDropContext in 'DragDropContext.pas', |
| DragDropHandler in 'DragDropHandler.pas', |
| DragDropComObj in 'DragDropComObj.pas', |
| DropHandler in 'DropHandler.pas'; |
| end. |
| /trunk/VCL_DRAGDROP/DragDropD6.res |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DragDropDesign.pas |
|---|
| 0,0 → 1,68 |
| unit DragDropDesign; |
| // ----------------------------------------------------------------------------- |
| // |
| // NOT FOR RELEASE |
| // |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite |
| // Module: DragDropDesign |
| // Description: Contains design-time support for the drag and drop |
| // components. |
| // Version: 4.0 |
| // Date: 25-JUN-2000 |
| // Target: Win32, Delphi 3-6 and C++ Builder 3-5 |
| // Authors: Angus Johnson, ajohnson@rpi.net.au |
| // Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2000 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| procedure Register; |
| implementation |
| {$include DragDrop.inc} |
| uses |
| DragDrop, |
| {$ifndef VER14_PLUS} |
| DsgnIntf, |
| {$else} |
| DesignIntf, |
| DesignEditors, |
| {$endif} |
| Classes; |
| type |
| TDataFormatNameEditor = class(TStringProperty) |
| public |
| function GetAttributes: TPropertyAttributes; override; |
| procedure GetValues(Proc: TGetStrProc); override; |
| end; |
| procedure Register; |
| begin |
| RegisterPropertyEditor(TypeInfo(string), TDataFormatAdapter, 'DataFormatName', |
| TDataFormatNameEditor); |
| end; |
| { TDataFormatNameEditor } |
| function TDataFormatNameEditor.GetAttributes: TPropertyAttributes; |
| begin |
| Result := [paValueList, paSortList, paMultiSelect]; |
| end; |
| type |
| TDataFormatClassesCracker = class(TDataFormatClasses); |
| procedure TDataFormatNameEditor.GetValues(Proc: TGetStrProc); |
| var |
| i : Integer; |
| begin |
| for i := 0 to TDataFormatClassesCracker.Instance.Count-1 do |
| Proc(TDataFormatClassesCracker.Instance[i].ClassName); |
| end; |
| end. |
| /trunk/VCL_DRAGDROP/DragDropFile.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DragDropFile.pas |
|---|
| 0,0 → 1,858 |
| unit DragDropFile; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite. |
| // Module: DragDropFile |
| // Description: Implements Dragging and Dropping of files and folders. |
| // Version: 4.0 |
| // Date: 18-MAY-2001 |
| // Target: Win32, Delphi 5-6 |
| // Authors: Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2001 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DragDrop, |
| DropTarget, |
| DropSource, |
| DragDropFormats, |
| ActiveX, |
| Windows, |
| Classes; |
| type |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TFileClipboardFormat = class(TCustomSimpleClipboardFormat) |
| private |
| FFiles: TStrings; |
| protected |
| function ReadData(Value: pointer; Size: integer): boolean; override; |
| function WriteData(Value: pointer; Size: integer): boolean; override; |
| function GetSize: integer; override; |
| public |
| constructor Create; override; |
| destructor Destroy; override; |
| function GetClipboardFormat: TClipFormat; override; |
| function Assign(Source: TCustomDataFormat): boolean; override; |
| function AssignTo(Dest: TCustomDataFormat): boolean; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| property Files: TStrings read FFiles; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFilenameClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TFilenameClipboardFormat = class(TCustomTextClipboardFormat) |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| function Assign(Source: TCustomDataFormat): boolean; override; |
| function AssignTo(Dest: TCustomDataFormat): boolean; override; |
| property Filename: string read GetString write SetString; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFilenameWClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TFilenameWClipboardFormat = class(TCustomWideTextClipboardFormat) |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| function Assign(Source: TCustomDataFormat): boolean; override; |
| function AssignTo(Dest: TCustomDataFormat): boolean; override; |
| property Filename: WideString read GetText write SetText; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFilenameMapClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // DONE -oanme -cStopShip : Rename TFilenameMapClipboardFormat to TFilenameMapClipboardFormat. Also wide version. |
| TFilenameMapClipboardFormat = class(TCustomSimpleClipboardFormat) |
| private |
| FFileMaps : TStrings; |
| protected |
| function ReadData(Value: pointer; Size: integer): boolean; override; |
| function WriteData(Value: pointer; Size: integer): boolean; override; |
| function GetSize: integer; override; |
| public |
| constructor Create; override; |
| destructor Destroy; override; |
| function GetClipboardFormat: TClipFormat; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| property FileMaps: TStrings read FFileMaps; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFilenameMapWClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TFilenameMapWClipboardFormat = class(TCustomSimpleClipboardFormat) |
| private |
| FFileMaps : TStrings; |
| protected |
| function ReadData(Value: pointer; Size: integer): boolean; override; |
| function WriteData(Value: pointer; Size: integer): boolean; override; |
| function GetSize: integer; override; |
| public |
| constructor Create; override; |
| destructor Destroy; override; |
| function GetClipboardFormat: TClipFormat; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| property FileMaps: TStrings read FFileMaps; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileMapDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TFileMapDataFormat = class(TCustomDataFormat) |
| private |
| FFileMaps : TStrings; |
| public |
| constructor Create(AOwner: TDragDropComponent); override; |
| destructor Destroy; override; |
| function Assign(Source: TClipboardFormat): boolean; override; |
| function AssignTo(Dest: TClipboardFormat): boolean; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function NeedsData: boolean; override; |
| property FileMaps: TStrings read FFileMaps; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TFileDataFormat = class(TCustomDataFormat) |
| private |
| FFiles : TStrings; |
| protected |
| public |
| constructor Create(AOwner: TDragDropComponent); override; |
| destructor Destroy; override; |
| function Assign(Source: TClipboardFormat): boolean; override; |
| function AssignTo(Dest: TClipboardFormat): boolean; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function NeedsData: boolean; override; |
| property Files: TStrings read FFiles; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropFileTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropFileTarget = class(TCustomDropMultiTarget) |
| private |
| FFileFormat : TFileDataFormat; |
| FFileMapFormat : TFileMapDataFormat; |
| protected |
| function GetFiles: TStrings; |
| function GetMappedNames: TStrings; |
| function GetPreferredDropEffect: LongInt; override; |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; override; |
| property Files: TStrings read GetFiles; |
| property MappedNames: TStrings read GetMappedNames; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropFileSource |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropFileSource = class(TCustomDropMultiSource) |
| private |
| FFileFormat : TFileDataFormat; |
| FFileMapFormat : TFileMapDataFormat; |
| function GetFiles: TStrings; |
| function GetMappedNames: TStrings; |
| protected |
| procedure SetFiles(AFiles: TStrings); |
| procedure SetMappedNames(ANames: TStrings); |
| public |
| constructor Create(aOwner: TComponent); override; |
| destructor Destroy; override; |
| published |
| property Files: TStrings read GetFiles write SetFiles; |
| // MappedNames is only needed if files need to be renamed during a drag op. |
| // E.g. dragging from 'Recycle Bin'. |
| property MappedNames: TStrings read GetMappedNames write SetMappedNames; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Misc. |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function ReadFilesFromHGlobal(const HGlob: HGlobal; Files: TStrings): boolean; // V4: renamed |
| function ReadFilesFromData(Data: pointer; Size: integer; Files: TStrings): boolean; |
| function ReadFilesFromZeroList(Data: pointer; Size: integer; |
| Wide: boolean; Files: TStrings): boolean; |
| function WriteFilesToZeroList(Data: pointer; Size: integer; |
| Wide: boolean; Files: TStrings): boolean; |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // IMPLEMENTATION |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| implementation |
| uses |
| DragDropPIDL, |
| SysUtils, |
| ShlObj; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| begin |
| RegisterComponents(DragDropComponentPalettePage, [TDropFileTarget, |
| TDropFileSource]); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Utilities |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function ReadFilesFromHGlobal(const HGlob: HGlobal; Files: TStrings): boolean; |
| var |
| DropFiles : PDropFiles; |
| begin |
| DropFiles := PDropFiles(GlobalLock(HGlob)); |
| try |
| Result := ReadFilesFromData(DropFiles, GlobalSize(HGlob), Files) |
| finally |
| GlobalUnlock(HGlob); |
| end; |
| end; |
| function ReadFilesFromData(Data: pointer; Size: integer; Files: TStrings): boolean; |
| var |
| Wide : boolean; |
| begin |
| Files.Clear; |
| if (Data <> nil) then |
| begin |
| Wide := PDropFiles(Data)^.fWide; |
| dec(Size, PDropFiles(Data)^.pFiles); |
| inc(PChar(Data), PDropFiles(Data)^.pFiles); |
| ReadFilesFromZeroList(Data, Size, Wide, Files); |
| end; |
| Result := (Files.Count > 0); |
| end; |
| function ReadFilesFromZeroList(Data: pointer; Size: integer; |
| Wide: boolean; Files: TStrings): boolean; |
| var |
| StringSize : integer; |
| begin |
| Result := False; |
| if (Data <> nil) then |
| while (Size > 0) and (PChar(Data)^ <> #0) do |
| begin |
| if (Wide) then |
| begin |
| Files.Add(PWideChar(Data)); |
| StringSize := (Length(PWideChar(Data)) + 1) * 2; |
| end else |
| begin |
| Files.Add(PChar(Data)); |
| StringSize := Length(PChar(Data)) + 1; |
| end; |
| inc(PChar(Data), StringSize); |
| dec(Size, StringSize); |
| Result := True; |
| end; |
| end; |
| function WriteFilesToZeroList(Data: pointer; Size: integer; |
| Wide: boolean; Files: TStrings): boolean; |
| var |
| i : integer; |
| begin |
| Result := False; |
| if (Data <> nil) then |
| begin |
| i := 0; |
| dec(Size); |
| while (Size > 0) and (i < Files.Count) do |
| begin |
| if (Wide) then |
| begin |
| StringToWideChar(Files[i], Data, Size); |
| dec(Size, (Length(Files[i])+1)*2); |
| end else |
| begin |
| StrPLCopy(Data, Files[i], Size); |
| dec(Size, Length(Files[i])+1); |
| end; |
| inc(PChar(Data), Length(Files[i])+1); |
| inc(i); |
| Result := True; |
| end; |
| // Final teminating zero. |
| if (Size >= 0) then |
| PChar(Data)^ := #0; |
| end; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TFileClipboardFormat.Create; |
| begin |
| inherited Create; |
| FFiles := TStringList.Create; |
| // Note: Setting dwAspect to DVASPECT_SHORT will request that the data source |
| // returns the file names in short (8.3) format. |
| // FFormatEtc.dwAspect := DVASPECT_SHORT; |
| end; |
| destructor TFileClipboardFormat.Destroy; |
| begin |
| FFiles.Free; |
| inherited Destroy; |
| end; |
| function TFileClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| Result := CF_HDROP; |
| end; |
| procedure TFileClipboardFormat.Clear; |
| begin |
| FFiles.Clear; |
| end; |
| function TFileClipboardFormat.HasData: boolean; |
| begin |
| Result := (FFiles.Count > 0); |
| end; |
| function TFileClipboardFormat.GetSize: integer; |
| var |
| i : integer; |
| begin |
| Result := SizeOf(TDropFiles) + FFiles.Count + 1; |
| for i := 0 to FFiles.Count-1 do |
| inc(Result, Length(FFiles[i])); |
| end; |
| function TFileClipboardFormat.ReadData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| Result := (Size > SizeOf(TDropFiles)); |
| if (not Result) then |
| exit; |
| Result := ReadFilesFromData(Value, Size, FFiles); |
| end; |
| function TFileClipboardFormat.WriteData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| Result := (Size > SizeOf(TDropFiles)); |
| if (not Result) then |
| exit; |
| PDropFiles(Value)^.pfiles := SizeOf(TDropFiles); |
| PDropFiles(Value)^.fwide := False; |
| inc(PChar(Value), SizeOf(TDropFiles)); |
| dec(Size, SizeOf(TDropFiles)); |
| WriteFilesToZeroList(Value, Size, False, FFiles); |
| end; |
| function TFileClipboardFormat.Assign(Source: TCustomDataFormat): boolean; |
| begin |
| if (Source is TFileDataFormat) then |
| begin |
| FFiles.Assign(TFileDataFormat(Source).Files); |
| Result := True; |
| end else |
| Result := inherited Assign(Source); |
| end; |
| function TFileClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean; |
| begin |
| if (Dest is TFileDataFormat) then |
| begin |
| TFileDataFormat(Dest).Files.Assign(FFiles); |
| Result := True; |
| end else |
| Result := inherited AssignTo(Dest); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFilenameClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_FILENAMEA: TClipFormat = 0; |
| function TFilenameClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_FILENAMEA = 0) then |
| CF_FILENAMEA := RegisterClipboardFormat(CFSTR_FILENAMEA); |
| Result := CF_FILENAMEA; |
| end; |
| function TFilenameClipboardFormat.Assign(Source: TCustomDataFormat): boolean; |
| begin |
| if (Source is TFileDataFormat) then |
| begin |
| Result := (TFileDataFormat(Source).Files.Count > 0); |
| if (Result) then |
| Filename := TFileDataFormat(Source).Files[0]; |
| end else |
| Result := inherited Assign(Source); |
| end; |
| function TFilenameClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean; |
| begin |
| if (Dest is TFileDataFormat) then |
| begin |
| TFileDataFormat(Dest).Files.Add(Filename); |
| Result := True; |
| end else |
| Result := inherited AssignTo(Dest); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFilenameWClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_FILENAMEW: TClipFormat = 0; |
| function TFilenameWClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_FILENAMEW = 0) then |
| CF_FILENAMEW := RegisterClipboardFormat(CFSTR_FILENAMEW); |
| Result := CF_FILENAMEW; |
| end; |
| function TFilenameWClipboardFormat.Assign(Source: TCustomDataFormat): boolean; |
| begin |
| if (Source is TFileDataFormat) then |
| begin |
| Result := (TFileDataFormat(Source).Files.Count > 0); |
| if (Result) then |
| Filename := TFileDataFormat(Source).Files[0]; |
| end else |
| Result := inherited Assign(Source); |
| end; |
| function TFilenameWClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean; |
| begin |
| if (Dest is TFileDataFormat) then |
| begin |
| TFileDataFormat(Dest).Files.Add(Filename); |
| Result := True; |
| end else |
| Result := inherited AssignTo(Dest); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFilenameMapClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_FILENAMEMAP: TClipFormat = 0; |
| constructor TFilenameMapClipboardFormat.Create; |
| begin |
| inherited Create; |
| FFileMaps := TStringList.Create; |
| end; |
| destructor TFilenameMapClipboardFormat.Destroy; |
| begin |
| FFileMaps.Free; |
| inherited Destroy; |
| end; |
| function TFilenameMapClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_FILENAMEMAP = 0) then |
| CF_FILENAMEMAP := RegisterClipboardFormat(CFSTR_FILENAMEMAPA); |
| Result := CF_FILENAMEMAP; |
| end; |
| procedure TFilenameMapClipboardFormat.Clear; |
| begin |
| FFileMaps.Clear; |
| end; |
| function TFilenameMapClipboardFormat.HasData: boolean; |
| begin |
| Result := (FFileMaps.Count > 0); |
| end; |
| function TFilenameMapClipboardFormat.GetSize: integer; |
| var |
| i : integer; |
| begin |
| Result := FFileMaps.Count + 1; |
| for i := 0 to FFileMaps.Count-1 do |
| inc(Result, Length(FFileMaps[i])); |
| end; |
| function TFilenameMapClipboardFormat.ReadData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| Result := ReadFilesFromZeroList(Value, Size, False, FFileMaps); |
| end; |
| function TFilenameMapClipboardFormat.WriteData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| Result := WriteFilesToZeroList(Value, Size, False, FFileMaps); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFilenameMapWClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_FILENAMEMAPW: TClipFormat = 0; |
| constructor TFilenameMapWClipboardFormat.Create; |
| begin |
| inherited Create; |
| FFileMaps := TStringList.Create; |
| end; |
| destructor TFilenameMapWClipboardFormat.Destroy; |
| begin |
| FFileMaps.Free; |
| inherited Destroy; |
| end; |
| function TFilenameMapWClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_FILENAMEMAPW = 0) then |
| CF_FILENAMEMAPW := RegisterClipboardFormat(CFSTR_FILENAMEMAPW); |
| Result := CF_FILENAMEMAPW; |
| end; |
| procedure TFilenameMapWClipboardFormat.Clear; |
| begin |
| FFileMaps.Clear; |
| end; |
| function TFilenameMapWClipboardFormat.HasData: boolean; |
| begin |
| Result := (FFileMaps.Count > 0); |
| end; |
| function TFilenameMapWClipboardFormat.GetSize: integer; |
| var |
| i : integer; |
| begin |
| Result := FFileMaps.Count + 1; |
| for i := 0 to FFileMaps.Count-1 do |
| inc(Result, Length(FFileMaps[i])); |
| inc(Result, Result); |
| end; |
| function TFilenameMapWClipboardFormat.ReadData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| Result := ReadFilesFromZeroList(Value, Size, True, FFileMaps); |
| end; |
| function TFilenameMapWClipboardFormat.WriteData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| Result := WriteFilesToZeroList(Value, Size, True, FFileMaps); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileMapDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TFileMapDataFormat.Create(AOwner: TDragDropComponent); |
| begin |
| inherited Create(AOwner); |
| FFileMaps := TStringList.Create; |
| TStringList(FFileMaps).OnChanging := DoOnChanging; |
| end; |
| destructor TFileMapDataFormat.Destroy; |
| begin |
| FFileMaps.Free; |
| inherited Destroy; |
| end; |
| function TFileMapDataFormat.Assign(Source: TClipboardFormat): boolean; |
| begin |
| Result := True; |
| if (Source is TFilenameMapClipboardFormat) then |
| FFileMaps.Assign(TFilenameMapClipboardFormat(Source).FileMaps) |
| else if (Source is TFilenameMapWClipboardFormat) then |
| FFileMaps.Assign(TFilenameMapWClipboardFormat(Source).FileMaps) |
| else |
| Result := inherited Assign(Source); |
| end; |
| function TFileMapDataFormat.AssignTo(Dest: TClipboardFormat): boolean; |
| begin |
| Result := True; |
| if (Dest is TFilenameMapClipboardFormat) then |
| TFilenameMapClipboardFormat(Dest).FileMaps.Assign(FFileMaps) |
| else if (Dest is TFilenameMapWClipboardFormat) then |
| TFilenameMapWClipboardFormat(Dest).FileMaps.Assign(FFileMaps) |
| else |
| Result := inherited AssignTo(Dest); |
| end; |
| procedure TFileMapDataFormat.Clear; |
| begin |
| FFileMaps.Clear; |
| end; |
| function TFileMapDataFormat.HasData: boolean; |
| begin |
| Result := (FFileMaps.Count > 0); |
| end; |
| function TFileMapDataFormat.NeedsData: boolean; |
| begin |
| Result := (FFileMaps.Count = 0); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TFileDataFormat.Create(AOwner: TDragDropComponent); |
| begin |
| inherited Create(AOwner); |
| FFiles := TStringList.Create; |
| TStringList(FFiles).OnChanging := DoOnChanging; |
| end; |
| destructor TFileDataFormat.Destroy; |
| begin |
| FFiles.Free; |
| inherited Destroy; |
| end; |
| function TFileDataFormat.Assign(Source: TClipboardFormat): boolean; |
| begin |
| Result := True; |
| if (Source is TFileClipboardFormat) then |
| FFiles.Assign(TFileClipboardFormat(Source).Files) |
| else if (Source is TPIDLClipboardFormat) then |
| FFiles.Assign(TPIDLClipboardFormat(Source).Filenames) |
| else |
| Result := inherited Assign(Source); |
| end; |
| function TFileDataFormat.AssignTo(Dest: TClipboardFormat): boolean; |
| begin |
| Result := True; |
| if (Dest is TFileClipboardFormat) then |
| TFileClipboardFormat(Dest).Files.Assign(FFiles) |
| else if (Dest is TPIDLClipboardFormat) then |
| TPIDLClipboardFormat(Dest).Filenames.Assign(FFiles) |
| else |
| Result := inherited AssignTo(Dest); |
| end; |
| procedure TFileDataFormat.Clear; |
| begin |
| FFiles.Clear; |
| end; |
| function TFileDataFormat.HasData: boolean; |
| begin |
| Result := (FFiles.Count > 0); |
| end; |
| function TFileDataFormat.NeedsData: boolean; |
| begin |
| Result := (FFiles.Count = 0); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropFileTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDropFileTarget.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| OptimizedMove := True; |
| FFileFormat := TFileDataFormat.Create(Self); |
| FFileMapFormat := TFileMapDataFormat.Create(Self); |
| end; |
| destructor TDropFileTarget.Destroy; |
| begin |
| FFileFormat.Free; |
| FFileMapFormat.Free; |
| inherited Destroy; |
| end; |
| function TDropFileTarget.GetFiles: TStrings; |
| begin |
| Result := FFileFormat.Files; |
| end; |
| function TDropFileTarget.GetMappedNames: TStrings; |
| begin |
| Result := FFileMapFormat.FileMaps; |
| end; |
| function TDropFileTarget.GetPreferredDropEffect: LongInt; |
| begin |
| Result := inherited GetPreferredDropEffect; |
| if (Result = DROPEFFECT_NONE) then |
| Result := DROPEFFECT_COPY; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropFileSource |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDropFileSource.Create(aOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| FFileFormat := TFileDataFormat.Create(Self); |
| FFileMapFormat := TFileMapDataFormat.Create(Self); |
| end; |
| destructor TDropFileSource.Destroy; |
| begin |
| FFileFormat.Free; |
| FFileMapFormat.Free; |
| inherited Destroy; |
| end; |
| function TDropFileSource.GetFiles: TStrings; |
| begin |
| Result := FFileFormat.Files; |
| end; |
| function TDropFileSource.GetMappedNames: TStrings; |
| begin |
| Result := FFileMapFormat.FileMaps; |
| end; |
| procedure TDropFileSource.SetFiles(AFiles: TStrings); |
| begin |
| FFileFormat.Files.Assign(AFiles); |
| end; |
| procedure TDropFileSource.SetMappedNames(ANames: TStrings); |
| begin |
| FFileMapFormat.FileMaps.Assign(ANames); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Initialization/Finalization |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| initialization |
| // Data format registration |
| TFileDataFormat.RegisterDataFormat; |
| TFileMapDataFormat.RegisterDataFormat; |
| // Clipboard format registration |
| TFileDataFormat.RegisterCompatibleFormat(TFileClipboardFormat, 0, csSourceTarget, [ddRead]); |
| TFileDataFormat.RegisterCompatibleFormat(TPIDLClipboardFormat, 1, csSourceTarget, [ddRead]); |
| TFileDataFormat.RegisterCompatibleFormat(TFilenameClipboardFormat, 2, csSourceTarget, [ddRead]); |
| TFileDataFormat.RegisterCompatibleFormat(TFilenameWClipboardFormat, 2, csSourceTarget, [ddRead]); |
| TFileMapDataFormat.RegisterCompatibleFormat(TFilenameMapClipboardFormat, 0, csSourceTarget, [ddRead]); |
| TFileMapDataFormat.RegisterCompatibleFormat(TFilenameMapWClipboardFormat, 0, csSourceTarget, [ddRead]); |
| finalization |
| // Data format unregistration |
| TFileDataFormat.UnregisterDataFormat; |
| TFileMapDataFormat.UnregisterDataFormat; |
| // Clipboard format unregistration |
| TFileClipboardFormat.UnregisterClipboardFormat; |
| TFilenameClipboardFormat.UnregisterClipboardFormat; |
| TFilenameWClipboardFormat.UnregisterClipboardFormat; |
| TFilenameMapClipboardFormat.UnregisterClipboardFormat; |
| TFilenameMapWClipboardFormat.UnregisterClipboardFormat; |
| end. |
| /trunk/VCL_DRAGDROP/DragDropFormats.pas |
|---|
| 0,0 → 1,2822 |
| unit DragDropFormats; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite. |
| // Module: DragDropFormats |
| // Description: Implements commonly used clipboard formats and base classes. |
| // Version: 4.0 |
| // Date: 18-MAY-2001 |
| // Target: Win32, Delphi 5-6 |
| // Authors: Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2001 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DragDrop, |
| Windows, |
| Classes, |
| ActiveX, |
| ShlObj; |
| {$include DragDrop.inc} |
| type |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TStreamList |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Utility class used by TFileContentsStreamClipboardFormat and |
| // TDataStreamDataFormat. |
| //////////////////////////////////////////////////////////////////////////////// |
| TStreamList = class(TObject) |
| private |
| FStreams : TStrings; |
| FOnChanging : TNotifyEvent; |
| protected |
| function GetStream(Index: integer): TStream; |
| function GetCount: integer; |
| procedure Changing; |
| public |
| constructor Create; |
| destructor Destroy; override; |
| function Add(Stream: TStream): integer; |
| function AddNamed(Stream: TStream; Name: string): integer; |
| procedure Delete(Index: integer); |
| procedure Clear; |
| procedure Assign(Value: TStreamList); |
| property Count: integer read GetCount; |
| property Streams[Index: integer]: TStream read GetStream; default; |
| property Names: TStrings read FStreams; |
| property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TInterfaceList |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // List of named interfaces. |
| // Note: Delphi 5 also implements a TInterfaceList, but it can not be used |
| // because it doesn't support change notification and isn't extensible. |
| //////////////////////////////////////////////////////////////////////////////// |
| // Utility class used by TFileContentsStorageClipboardFormat. |
| //////////////////////////////////////////////////////////////////////////////// |
| TInterfaceList = class(TObject) |
| private |
| FList : TStrings; |
| FOnChanging : TNotifyEvent; |
| protected |
| function GetCount: integer; |
| function GetName(Index: integer): string; |
| function GetItem(Index: integer): IUnknown; |
| procedure Changing; |
| public |
| constructor Create; |
| destructor Destroy; override; |
| function Add(Item: IUnknown): integer; |
| function AddNamed(Item: IUnknown; Name: string): integer; |
| procedure Delete(Index: integer); |
| procedure Clear; |
| procedure Assign(Value: TInterfaceList); |
| property Items[Index: integer]: IUnknown read GetItem; default; |
| property Names[Index: integer]: string read GetName; |
| property Count: integer read GetCount; |
| property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TStorageInterfaceList |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // List of IStorage interfaces. |
| // Used by TFileContentsStorageClipboardFormat. |
| //////////////////////////////////////////////////////////////////////////////// |
| TStorageInterfaceList = class(TInterfaceList) |
| private |
| protected |
| function GetStorage(Index: integer): IStorage; |
| public |
| property Storages[Index: integer]: IStorage read GetStorage; default; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFixedStreamAdapter |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // TFixedStreamAdapter fixes several serious bugs in TStreamAdapter.CopyTo. |
| //////////////////////////////////////////////////////////////////////////////// |
| TFixedStreamAdapter = class(TStreamAdapter, IStream) |
| public |
| function CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint; |
| out cbWritten: Largeint): HResult; override; stdcall; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TMemoryList |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // List which owns the memory blocks it points to. |
| //////////////////////////////////////////////////////////////////////////////// |
| TMemoryList = class(TObject) |
| private |
| FList: TList; |
| protected |
| function Get(Index: Integer): Pointer; |
| function GetCount: Integer; |
| public |
| constructor Create; |
| destructor Destroy; override; |
| function Add(Item: Pointer): Integer; |
| procedure Clear; |
| procedure Delete(Index: Integer); |
| property Count: Integer read GetCount; |
| property Items[Index: Integer]: Pointer read Get; default; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomSimpleClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Abstract base class for simple clipboard formats stored in global memory |
| // or a stream. |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Two different methods of data transfer from the medium to the object are |
| // supported: |
| // |
| // 1) Descendant class reads data from a buffer provided by the base class. |
| // |
| // 2) Base class reads data from a buffer provided by the descendant class. |
| // |
| // Method #1 only requires that the descedant class implements the ReadData. |
| // |
| // Method #2 requires that the descedant class overrides the default |
| // DoGetDataSized method. The descedant DoGetDataSized method should allocate a |
| // buffer of the specified size and then call the ReadDataInto method to |
| // transfer data to the buffer. Even though the ReadData method will not be used |
| // in this scenario, it should be implemented as an empty method (to avoid |
| // abstract warnings). |
| // |
| // The WriteData method must be implemented regardless of which of the two |
| // approaches the class implements. |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TCustomSimpleClipboardFormat = class(TClipboardFormat) |
| private |
| protected |
| function DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean; override; |
| //: Transfer data from medium to a buffer of the specified size. |
| function DoGetDataSized(ADataObject: IDataObject; const AMedium: TStgMedium; |
| Size: integer): boolean; virtual; |
| //: Transfer data from the specified buffer to the objects storage. |
| function ReadData(Value: pointer; Size: integer): boolean; virtual; abstract; |
| //: Transfer data from the medium to the specified buffer. |
| function ReadDataInto(ADataObject: IDataObject; const AMedium: TStgMedium; |
| Buffer: pointer; Size: integer): boolean; virtual; |
| function DoSetData(const FormatEtcIn: TFormatEtc; |
| var AMedium: TStgMedium): boolean; override; |
| //: Transfer data from the objects storage to the specified buffer. |
| function WriteData(Value: pointer; Size: integer): boolean; virtual; abstract; |
| function GetSize: integer; virtual; abstract; |
| public |
| constructor Create; override; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomStringClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Abstract base class for simple clipboard formats. |
| // The data is stored in a string. |
| //////////////////////////////////////////////////////////////////////////////// |
| TCustomStringClipboardFormat = class(TCustomSimpleClipboardFormat) |
| private |
| FData: string; |
| FTrimZeroes: boolean; |
| protected |
| function ReadData(Value: pointer; Size: integer): boolean; override; |
| function WriteData(Value: pointer; Size: integer): boolean; override; |
| function GetSize: integer; override; |
| function GetString: string; |
| procedure SetString(const Value: string); |
| property Data: string read FData write FData; // DONE : Why is SetString used instead of FData? |
| public |
| procedure Clear; override; |
| function HasData: boolean; override; |
| property TrimZeroes: boolean read FTrimZeroes write FTrimZeroes; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomStringListClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Abstract base class for simple cr/lf delimited string clipboard formats. |
| // The data is stored in a TStringList. |
| //////////////////////////////////////////////////////////////////////////////// |
| TCustomStringListClipboardFormat = class(TCustomSimpleClipboardFormat) |
| private |
| FLines : TStrings; |
| protected |
| function ReadData(Value: pointer; Size: integer): boolean; override; |
| function WriteData(Value: pointer; Size: integer): boolean; override; |
| function GetSize: integer; override; |
| function GetLines: TStrings; |
| property Lines: TStrings read FLines; |
| public |
| constructor Create; override; |
| destructor Destroy; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomTextClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Abstract base class for simple text based clipboard formats. |
| //////////////////////////////////////////////////////////////////////////////// |
| TCustomTextClipboardFormat = class(TCustomStringClipboardFormat) |
| private |
| protected |
| function GetSize: integer; override; |
| property Text: string read GetString write SetString; |
| public |
| constructor Create; override; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomWideTextClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Abstract base class for simple wide string clipboard formats storing the data |
| // in a wide string. |
| //////////////////////////////////////////////////////////////////////////////// |
| TCustomWideTextClipboardFormat = class(TCustomSimpleClipboardFormat) |
| private |
| FText : WideString; |
| protected |
| function ReadData(Value: pointer; Size: integer): boolean; override; |
| function WriteData(Value: pointer; Size: integer): boolean; override; |
| function GetSize: integer; override; |
| function GetText: WideString; |
| procedure SetText(const Value: WideString); |
| property Text: WideString read FText write FText; |
| public |
| procedure Clear; override; |
| function HasData: boolean; override; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TTextClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TTextClipboardFormat = class(TCustomTextClipboardFormat) |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| property Text; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomDWORDClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TCustomDWORDClipboardFormat = class(TCustomSimpleClipboardFormat) |
| private |
| FValue : DWORD; |
| protected |
| function ReadData(Value: pointer; Size: integer): boolean; override; |
| function WriteData(Value: pointer; Size: integer): boolean; override; |
| function GetSize: integer; override; |
| function GetValueDWORD: DWORD; |
| procedure SetValueDWORD(Value: DWORD); |
| function GetValueInteger: integer; |
| procedure SetValueInteger(Value: integer); |
| function GetValueLongInt: longInt; |
| procedure SetValueLongInt(Value: longInt); |
| function GetValueBoolean: boolean; |
| procedure SetValueBoolean(Value: boolean); |
| public |
| procedure Clear; override; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileGroupDescritorClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TFileGroupDescritorClipboardFormat = class(TCustomSimpleClipboardFormat) |
| private |
| FFileGroupDescriptor : PFileGroupDescriptor; |
| protected |
| function ReadData(Value: pointer; Size: integer): boolean; override; |
| function WriteData(Value: pointer; Size: integer): boolean; override; |
| function GetSize: integer; override; |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| destructor Destroy; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| property FileGroupDescriptor: PFileGroupDescriptor read FFileGroupDescriptor; |
| procedure CopyFrom(AFileGroupDescriptor: PFileGroupDescriptor); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileGroupDescritorWClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Warning: TFileGroupDescriptorW has wrong declaration in ShlObj.pas! |
| TFileGroupDescriptorW = record |
| cItems: UINT; |
| fgd: array[0..0] of TFileDescriptorW; |
| end; |
| PFileGroupDescriptorW = ^TFileGroupDescriptorW; |
| TFileGroupDescritorWClipboardFormat = class(TCustomSimpleClipboardFormat) |
| private |
| FFileGroupDescriptor : PFileGroupDescriptorW; |
| protected |
| function ReadData(Value: pointer; Size: integer): boolean; override; |
| function WriteData(Value: pointer; Size: integer): boolean; override; |
| function GetSize: integer; override; |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| destructor Destroy; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| property FileGroupDescriptor: PFileGroupDescriptorW read FFileGroupDescriptor; |
| procedure CopyFrom(AFileGroupDescriptor: PFileGroupDescriptorW); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileContentsClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Note: File contents must be zero terminated, so we descend from |
| // TCustomTextClipboardFormat instead of TCustomStringClipboardFormat. |
| //////////////////////////////////////////////////////////////////////////////// |
| TFileContentsClipboardFormat = class(TCustomTextClipboardFormat) |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| constructor Create; override; |
| property Data; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileContentsStreamClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TFileContentsStreamClipboardFormat = class(TClipboardFormat) |
| private |
| FStreams: TStreamList; |
| protected |
| public |
| constructor Create; override; |
| destructor Destroy; override; |
| function GetClipboardFormat: TClipFormat; override; |
| function GetData(DataObject: IDataObject): boolean; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function AssignTo(Dest: TCustomDataFormat): boolean; override; |
| property Streams: TStreamList read FStreams; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileContentsStreamOnDemandClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Yeah, it's a long name, but I like my names descriptive. |
| //////////////////////////////////////////////////////////////////////////////// |
| TVirtualFileStreamDataFormat = class; |
| TFileContentsStreamOnDemandClipboardFormat = class; |
| TOnGetStreamEvent = procedure(Sender: TFileContentsStreamOnDemandClipboardFormat; |
| Index: integer; out AStream: IStream) of object; |
| TFileContentsStreamOnDemandClipboardFormat = class(TClipboardFormat) |
| private |
| FOnGetStream: TOnGetStreamEvent; |
| FGotData: boolean; |
| FDataRequested: boolean; |
| protected |
| function DoSetData(const FormatEtcIn: TFormatEtc; |
| var AMedium: TStgMedium): boolean; override; |
| public |
| constructor Create; override; |
| destructor Destroy; override; |
| function GetClipboardFormat: TClipFormat; override; |
| function GetData(DataObject: IDataObject): boolean; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function AssignTo(Dest: TCustomDataFormat): boolean; override; |
| function Assign(Source: TCustomDataFormat): boolean; override; |
| function GetStream(Index: integer): IStream; |
| property OnGetStream: TOnGetStreamEvent read FOnGetStream write FOnGetStream; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileContentsStorageClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TFileContentsStorageClipboardFormat = class(TClipboardFormat) |
| private |
| FStorages : TStorageInterfaceList; |
| protected |
| public |
| constructor Create; override; |
| destructor Destroy; override; |
| function GetClipboardFormat: TClipFormat; override; |
| function GetData(DataObject: IDataObject): boolean; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function AssignTo(Dest: TCustomDataFormat): boolean; override; |
| property Storages: TStorageInterfaceList read FStorages; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TPreferredDropEffectClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TPreferredDropEffectClipboardFormat = class(TCustomDWORDClipboardFormat) |
| public |
| class function GetClassClipboardFormat: TClipFormat; |
| function GetClipboardFormat: TClipFormat; override; |
| function HasData: boolean; override; |
| property Value: longInt read GetValueLongInt write SetValueLongInt; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TPerformedDropEffectClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TPerformedDropEffectClipboardFormat = class(TCustomDWORDClipboardFormat) |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| property Value: longInt read GetValueLongInt write SetValueLongInt; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TLogicalPerformedDropEffectClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Microsoft's latest (so far) "logical" solution to the never ending attempts |
| // of reporting back to the source which operation actually took place. Sigh! |
| //////////////////////////////////////////////////////////////////////////////// |
| TLogicalPerformedDropEffectClipboardFormat = class(TCustomDWORDClipboardFormat) |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| property Value: longInt read GetValueLongInt write SetValueLongInt; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TPasteSuccededClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TPasteSuccededClipboardFormat = class(TCustomDWORDClipboardFormat) |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| property Value: longInt read GetValueLongInt write SetValueLongInt; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TInDragLoopClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TInShellDragLoopClipboardFormat = class(TCustomDWORDClipboardFormat) |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| property InShellDragLoop: boolean read GetValueBoolean write SetValueBoolean; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TTargetCLSIDClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TTargetCLSIDClipboardFormat = class(TCustomSimpleClipboardFormat) |
| private |
| FCLSID: TCLSID; |
| protected |
| function ReadData(Value: pointer; Size: integer): boolean; override; |
| function WriteData(Value: pointer; Size: integer): boolean; override; |
| function GetSize: integer; override; |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| property CLSID: TCLSID read FCLSID write FCLSID; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TTextDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TTextDataFormat = class(TCustomDataFormat) |
| private |
| FText : string; |
| protected |
| procedure SetText(const Value: string); |
| public |
| function Assign(Source: TClipboardFormat): boolean; override; |
| function AssignTo(Dest: TClipboardFormat): boolean; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function NeedsData: boolean; override; |
| property Text: string read FText write SetText; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDataStreamDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TDataStreamDataFormat = class(TCustomDataFormat) |
| private |
| FStreams : TStreamList; |
| public |
| constructor Create(AOwner: TDragDropComponent); override; |
| destructor Destroy; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function NeedsData: boolean; override; |
| property Streams: TStreamList read FStreams; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TVirtualFileStreamDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TVirtualFileStreamDataFormat = class(TCustomDataFormat) |
| private |
| FFileDescriptors: TMemoryList; |
| FFileNames: TStrings; |
| FFileContentsClipboardFormat: TFileContentsStreamOnDemandClipboardFormat; |
| FFileGroupDescritorClipboardFormat: TFileGroupDescritorClipboardFormat; |
| FHasContents: boolean; |
| protected |
| procedure SetFileNames(const Value: TStrings); |
| function GetOnGetStream: TOnGetStreamEvent; |
| procedure SetOnGetStream(const Value: TOnGetStreamEvent); |
| public |
| constructor Create(AOwner: TDragDropComponent); override; |
| destructor Destroy; override; |
| function Assign(Source: TClipboardFormat): boolean; override; |
| function AssignTo(Dest: TClipboardFormat): boolean; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function NeedsData: boolean; override; |
| property FileDescriptors: TMemoryList read FFileDescriptors; |
| property FileNames: TStrings read FFileNames write SetFileNames; |
| property FileContentsClipboardFormat: TFileContentsStreamOnDemandClipboardFormat |
| read FFileContentsClipboardFormat; |
| property FileGroupDescritorClipboardFormat: TFileGroupDescritorClipboardFormat |
| read FFileGroupDescritorClipboardFormat; |
| property OnGetStream: TOnGetStreamEvent read GetOnGetStream write SetOnGetStream; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFeedbackDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Data used for communication between source and target. |
| // Only used by the drop source. |
| //////////////////////////////////////////////////////////////////////////////// |
| TFeedbackDataFormat = class(TCustomDataFormat) |
| private |
| FPreferredDropEffect: longInt; |
| FPerformedDropEffect: longInt; |
| FLogicalPerformedDropEffect: longInt; |
| FPasteSucceded: longInt; |
| FInShellDragLoop: boolean; |
| FGotInShellDragLoop: boolean; |
| FTargetCLSID: TCLSID; |
| protected |
| procedure SetInShellDragLoop(const Value: boolean); |
| procedure SetPasteSucceded(const Value: longInt); |
| procedure SetPerformedDropEffect(const Value: longInt); |
| procedure SetPreferredDropEffect(const Value: longInt); |
| procedure SetTargetCLSID(const Value: TCLSID); |
| procedure SetLogicalPerformedDropEffect(const Value: Integer); |
| public |
| function Assign(Source: TClipboardFormat): boolean; override; |
| function AssignTo(Dest: TClipboardFormat): boolean; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function NeedsData: boolean; override; |
| property PreferredDropEffect: longInt read FPreferredDropEffect |
| write SetPreferredDropEffect; |
| property PerformedDropEffect: longInt read FPerformedDropEffect |
| write SetPerformedDropEffect; |
| property LogicalPerformedDropEffect: longInt read FLogicalPerformedDropEffect |
| write SetLogicalPerformedDropEffect; |
| property PasteSucceded: longInt read FPasteSucceded write SetPasteSucceded; |
| property InShellDragLoop: boolean read FInShellDragLoop |
| write SetInShellDragLoop; |
| property TargetCLSID: TCLSID read FTargetCLSID write SetTargetCLSID; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TGenericClipboardFormat & TGenericDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // TGenericDataFormat is not used internally by the library, but can be used to |
| // add support for new formats with a minimum of custom code. |
| // Even though TGenericDataFormat represents the data as a string, it can be |
| // used to transfer any kind of data. |
| // TGenericClipboardFormat is used internally by TGenericDataFormat but can also |
| // be used by other TCustomDataFormat descendants or as a base class for new |
| // clipboard formats. |
| // Note that you should not register TGenericClipboardFormat as compatible with |
| // TGenericDataFormat. |
| // To use TGenericDataFormat, all you need to do is instantiate it against |
| // the desired component and register your custom clipboard formats: |
| // |
| // var |
| // MyCustomData: TGenericDataFormat; |
| // |
| // MyCustomData := TGenericDataFormat.Create(DropTextTarget1); |
| // MyCustomData.AddFormat('MyCustomFormat'); |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TGenericDataFormat = class(TCustomDataFormat) |
| private |
| FData : string; |
| protected |
| function GetSize: integer; |
| procedure DoSetData(const Value: string); |
| public |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function NeedsData: boolean; override; |
| procedure AddFormat(const AFormat: string); |
| procedure SetDataHere(const AData; ASize: integer); |
| function GetDataHere(var AData; ASize: integer): integer; |
| property Data: string read FData write DoSetData; |
| property Size: integer read GetSize; |
| end; |
| TGenericClipboardFormat = class(TCustomStringClipboardFormat) |
| private |
| FFormat: string; |
| protected |
| procedure SetClipboardFormatName(const Value: string); override; |
| function GetClipboardFormatName: string; override; |
| function GetClipboardFormat: TClipFormat; override; |
| public |
| function Assign(Source: TCustomDataFormat): boolean; override; |
| function AssignTo(Dest: TCustomDataFormat): boolean; override; |
| property Data; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // IMPLEMENTATION |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| implementation |
| uses |
| DropSource, |
| DropTarget, |
| SysUtils; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TStreamList |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TStreamList.Create; |
| begin |
| inherited Create; |
| FStreams := TStringList.Create; |
| end; |
| destructor TStreamList.Destroy; |
| begin |
| Clear; |
| FStreams.Free; |
| inherited Destroy; |
| end; |
| procedure TStreamList.Changing; |
| begin |
| if (Assigned(OnChanging)) then |
| OnChanging(Self); |
| end; |
| function TStreamList.GetStream(Index: integer): TStream; |
| begin |
| Result := TStream(FStreams.Objects[Index]); |
| end; |
| function TStreamList.Add(Stream: TStream): integer; |
| begin |
| Result := AddNamed(Stream, ''); |
| end; |
| function TStreamList.AddNamed(Stream: TStream; Name: string): integer; |
| begin |
| Changing; |
| Result := FStreams.AddObject(Name, Stream); |
| end; |
| function TStreamList.GetCount: integer; |
| begin |
| Result := FStreams.Count; |
| end; |
| procedure TStreamList.Assign(Value: TStreamList); |
| begin |
| Clear; |
| FStreams.Assign(Value.Names); |
| // Transfer ownership of objects |
| Value.FStreams.Clear; |
| end; |
| procedure TStreamList.Delete(Index: integer); |
| begin |
| Changing; |
| FStreams.Delete(Index); |
| end; |
| procedure TStreamList.Clear; |
| var |
| i : integer; |
| begin |
| Changing; |
| for i := 0 to FStreams.Count-1 do |
| if (FStreams.Objects[i] <> nil) then |
| FStreams.Objects[i].Free; |
| FStreams.Clear; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TInterfaceList |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TInterfaceList.Create; |
| begin |
| inherited Create; |
| FList := TStringList.Create; |
| end; |
| destructor TInterfaceList.Destroy; |
| begin |
| Clear; |
| FList.Free; |
| inherited Destroy; |
| end; |
| function TInterfaceList.Add(Item: IUnknown): integer; |
| begin |
| Result := AddNamed(Item, ''); |
| end; |
| function TInterfaceList.AddNamed(Item: IUnknown; Name: string): integer; |
| begin |
| Changing; |
| with FList do |
| begin |
| Result := AddObject(Name, nil); |
| Objects[Result] := TObject(Item); |
| Item._AddRef; |
| end; |
| end; |
| procedure TInterfaceList.Changing; |
| begin |
| if (Assigned(OnChanging)) then |
| OnChanging(Self); |
| end; |
| procedure TInterfaceList.Clear; |
| var |
| i : Integer; |
| p : pointer; |
| begin |
| Changing; |
| with FList do |
| begin |
| for i := 0 to Count - 1 do |
| begin |
| p := Objects[i]; |
| IUnknown(p) := nil; |
| end; |
| Clear; |
| end; |
| end; |
| procedure TInterfaceList.Assign(Value: TInterfaceList); |
| var |
| i : Integer; |
| begin |
| Changing; |
| for i := 0 to Value.Count - 1 do |
| AddNamed(Value.Items[i], Value.Names[i]); |
| end; |
| procedure TInterfaceList.Delete(Index: integer); |
| var |
| p : pointer; |
| begin |
| Changing; |
| with FList do |
| begin |
| p := Objects[Index]; |
| IUnknown(p) := nil; |
| Delete(Index); |
| end; |
| end; |
| function TInterfaceList.GetCount: integer; |
| begin |
| Result := FList.Count; |
| end; |
| function TInterfaceList.GetName(Index: integer): string; |
| begin |
| Result := FList[Index]; |
| end; |
| function TInterfaceList.GetItem(Index: integer): IUnknown; |
| var |
| p : pointer; |
| begin |
| p := FList.Objects[Index]; |
| Result := IUnknown(p); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TStorageInterfaceList |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TStorageInterfaceList.GetStorage(Index: integer): IStorage; |
| begin |
| Result := IStorage(Items[Index]); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TMemoryList |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TMemoryList.Add(Item: Pointer): Integer; |
| begin |
| Result := FList.Add(Item); |
| end; |
| procedure TMemoryList.Clear; |
| var |
| i: integer; |
| begin |
| for i := FList.Count-1 downto 0 do |
| Delete(i); |
| end; |
| constructor TMemoryList.Create; |
| begin |
| inherited Create; |
| FList := TList.Create; |
| end; |
| procedure TMemoryList.Delete(Index: Integer); |
| begin |
| Freemem(FList[Index]); |
| FList.Delete(Index); |
| end; |
| destructor TMemoryList.Destroy; |
| begin |
| FList.Free; |
| inherited Destroy; |
| end; |
| function TMemoryList.Get(Index: Integer): Pointer; |
| begin |
| Result := FList[Index]; |
| end; |
| function TMemoryList.GetCount: Integer; |
| begin |
| Result := FList.Count; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFixedStreamAdapter |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TFixedStreamAdapter.CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint; |
| out cbWritten: Largeint): HResult; |
| const |
| MaxBufSize = 1024 * 1024; // 1mb |
| var |
| Buffer: Pointer; |
| BufSize, BurstReadSize, BurstWriteSize: Integer; |
| BytesRead, BytesWritten, BurstWritten: LongInt; |
| begin |
| Result := S_OK; |
| BytesRead := 0; |
| BytesWritten := 0; |
| try |
| if (cb < 0) then |
| begin |
| // Note: The folowing is a workaround for a design bug in either explorer |
| // or the clipboard. See comment in TCustomSimpleClipboardFormat.DoSetData |
| // for an explanation. |
| if (Stream.Position = Stream.Size) then |
| Stream.Position := 0; |
| cb := Stream.Size - Stream.Position; |
| end; |
| if cb > MaxBufSize then |
| BufSize := MaxBufSize |
| else |
| BufSize := Integer(cb); |
| GetMem(Buffer, BufSize); |
| try |
| while cb > 0 do |
| begin |
| if cb > BufSize then |
| BurstReadSize := BufSize |
| else |
| BurstReadSize := cb; |
| BurstWriteSize := Stream.Read(Buffer^, BurstReadSize); |
| if (BurstWriteSize = 0) then |
| break; |
| Inc(BytesRead, BurstWriteSize); |
| BurstWritten := 0; |
| Result := stm.Write(Buffer, BurstWriteSize, @BurstWritten); |
| Inc(BytesWritten, BurstWritten); |
| if (Result = S_OK) and (Integer(BurstWritten) <> BurstWriteSize) then |
| Result := E_FAIL; |
| if Result <> S_OK then |
| Exit; |
| Dec(cb, BurstWritten); |
| end; |
| finally |
| FreeMem(Buffer); |
| if (@cbWritten <> nil) then |
| cbWritten := BytesWritten; |
| if (@cbRead <> nil) then |
| cbRead := BytesRead; |
| end; |
| except |
| Result := E_UNEXPECTED; |
| end; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomSimpleClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TCustomSimpleClipboardFormat.Create; |
| begin |
| CreateFormat(TYMED_HGLOBAL or TYMED_ISTREAM); |
| end; |
| function TCustomSimpleClipboardFormat.DoGetData(ADataObject: IDataObject; |
| const AMedium: TStgMedium): boolean; |
| var |
| Stream : IStream; |
| StatStg : TStatStg; |
| Size : integer; |
| begin |
| // Get size from HGlobal. |
| if (AMedium.tymed and TYMED_HGLOBAL <> 0) then |
| begin |
| Size := GlobalSize(AMedium.HGlobal); |
| Result := True; |
| end else |
| // Get size from IStream. |
| if (AMedium.tymed and TYMED_ISTREAM <> 0) then |
| begin |
| Stream := IStream(AMedium.stm); |
| Result := (Stream <> nil) and (Stream.Stat(StatStg, STATFLAG_NONAME) = S_OK); |
| Size := StatStg.cbSize; |
| Stream := nil; // Not really nescessary. |
| end else |
| begin |
| Size := 0; |
| Result := False; |
| end; |
| if (Result) and (Size > 0) then |
| begin |
| // Read the given amount of data. |
| Result := DoGetDataSized(ADataObject, AMedium, Size); |
| end; |
| end; |
| function TCustomSimpleClipboardFormat.DoGetDataSized(ADataObject: IDataObject; |
| const AMedium: TStgMedium; Size: integer): boolean; |
| var |
| Buffer: pointer; |
| Stream: IStream; |
| Remaining: longInt; |
| Chunk: longInt; |
| pChunk: PChar; |
| begin |
| if (Size > 0) then |
| begin |
| (* |
| ** In this method we prefer TYMED_HGLOBAL over TYMED_ISTREAM and thus check |
| ** for TYMED_HGLOBAL first. |
| *) |
| // Read data from HGlobal |
| if (AMedium.tymed and TYMED_HGLOBAL <> 0) then |
| begin |
| // Use global memory as buffer |
| Buffer := GlobalLock(AMedium.HGlobal); |
| try |
| // Read data from buffer into object |
| Result := (Buffer <> nil) and (ReadData(Buffer, Size)); |
| finally |
| GlobalUnlock(AMedium.HGlobal); |
| end; |
| end else |
| // Read data from IStream |
| if (AMedium.tymed and TYMED_ISTREAM <> 0) then |
| begin |
| // Allocate buffer |
| GetMem(Buffer, Size); |
| try |
| // Read data from stream into buffer |
| Stream := IStream(AMedium.stm); |
| if (Stream <> nil) then |
| begin |
| Stream.Seek(0, STREAM_SEEK_SET, PLargeuint(nil)^); |
| Result := True; |
| Remaining := Size; |
| pChunk := Buffer; |
| while (Result) and (Remaining > 0) do |
| begin |
| Result := (Stream.Read(pChunk, Remaining, @Chunk) = S_OK); |
| if (Chunk = 0) then |
| break; |
| inc(pChunk, Chunk); |
| dec(Remaining, Chunk); |
| end; |
| Stream := nil; // Not really nescessary. |
| end else |
| Result := False; |
| // Transfer data from buffer into object. |
| Result := Result and (ReadData(Buffer, Size)); |
| finally |
| FreeMem(Buffer); |
| end; |
| end else |
| Result := False; |
| end else |
| Result := False; |
| end; |
| function TCustomSimpleClipboardFormat.ReadDataInto(ADataObject: IDataObject; |
| const AMedium: TStgMedium; Buffer: pointer; Size: integer): boolean; |
| var |
| Stream: IStream; |
| p: pointer; |
| Remaining: longInt; |
| Chunk: longInt; |
| begin |
| Result := (Buffer <> nil) and (Size > 0); |
| if (Result) then |
| begin |
| // Read data from HGlobal |
| if (AMedium.tymed and TYMED_HGLOBAL <> 0) then |
| begin |
| p := GlobalLock(AMedium.HGlobal); |
| try |
| Result := (p <> nil); |
| if (Result) then |
| Move(p^, Buffer^, Size); |
| finally |
| GlobalUnlock(AMedium.HGlobal); |
| end; |
| end else |
| // Read data from IStream |
| if (AMedium.tymed and TYMED_ISTREAM <> 0) then |
| begin |
| Stream := IStream(AMedium.stm); |
| if (Stream <> nil) then |
| begin |
| Stream.Seek(0, STREAM_SEEK_SET, PLargeuint(nil)^); |
| Remaining := Size; |
| while (Result) and (Remaining > 0) do |
| begin |
| Result := (Stream.Read(Buffer, Remaining, @Chunk) = S_OK); |
| if (Chunk = 0) then |
| break; |
| inc(PChar(Buffer), Chunk); |
| dec(Remaining, Chunk); |
| end; |
| end else |
| Result := False; |
| end else |
| Result := False; |
| end; |
| end; |
| function TCustomSimpleClipboardFormat.DoSetData(const FormatEtcIn: TFormatEtc; |
| var AMedium: TStgMedium): boolean; |
| var |
| p: pointer; |
| Size: integer; |
| Stream: TMemoryStream; |
| // Warning: TStreamAdapter.CopyTo is broken! |
| StreamAdapter: TStreamAdapter; |
| begin |
| Result := False; |
| Size := GetSize; |
| if (Size <= 0) then |
| exit; |
| if (FormatEtcIn.tymed and TYMED_ISTREAM <> 0) then |
| begin |
| Stream := TMemoryStream.Create; |
| StreamAdapter := TFixedStreamAdapter.Create(Stream, soOwned); |
| try |
| Stream.Size := Size; |
| Result := WriteData(Stream.Memory, Size); |
| // Note: Conflicting information on which of the following two are correct: |
| // |
| // 1) Stream.Position := Size; |
| // |
| // 2) Stream.Position := 0; |
| // |
| // #1 is required for clipboard operations to succeed; The clipboard uses |
| // a Seek(0, STREAM_SEEK_CUR) to determine the size of the stream. |
| // |
| // #2 is required for shell operations to succeed; The shell uses a |
| // Read(-1) to read all of the stream. |
| // |
| // This library uses a Stream.Stat to determine the size of the stream and |
| // then reads from start to end of stream. |
| // |
| // Since we use #1 (see below), we work around #2 in |
| // TFixedStreamAdapter.CopyTo. |
| if (Result) then |
| begin |
| Stream.Position := Size; |
| IStream(AMedium.stm) := StreamAdapter as IStream; |
| end; |
| except |
| Result := False; |
| end; |
| if (not Result) then |
| begin |
| StreamAdapter.Free; |
| AMedium.stm := nil; |
| end else |
| AMedium.tymed := TYMED_ISTREAM; |
| end else |
| if (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then |
| begin |
| AMedium.hGlobal := GlobalAlloc(GMEM_SHARE or GHND, Size); |
| if (AMedium.hGlobal = 0) then |
| exit; |
| try |
| p := GlobalLock(AMedium.hGlobal); |
| try |
| Result := (p <> nil) and WriteData(p, Size); |
| finally |
| GlobalUnlock(AMedium.hGlobal); |
| end; |
| except |
| Result := False; |
| end; |
| if (not Result) then |
| begin |
| GlobalFree(AMedium.hGlobal); |
| AMedium.hGlobal := 0; |
| end else |
| AMedium.tymed := TYMED_HGLOBAL; |
| end else |
| Result := False; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomStringClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure TCustomStringClipboardFormat.Clear; |
| begin |
| FData := ''; |
| end; |
| function TCustomStringClipboardFormat.HasData: boolean; |
| begin |
| Result := (FData <> ''); |
| end; |
| function TCustomStringClipboardFormat.ReadData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| SetLength(FData, Size); |
| Move(Value^, PChar(FData)^, Size); |
| // IE adds a lot of trailing zeroes which is included in the string length. |
| // To avoid confusion, we trim all trailing zeroes but the last (which is |
| // managed automatically by Delphi). |
| // Note that since this work around, if applied generally, would mean that we |
| // couldn't use this class to handle arbitrary binary data (which might |
| // include zeroes), we are required to explicitly enable it in the classes |
| // where we need it (e.g. all TCustomTextClipboardFormat descedants). |
| if (FTrimZeroes) then |
| SetLength(FData, Length(PChar(FData))); |
| Result := True; |
| end; |
| function TCustomStringClipboardFormat.WriteData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| // Transfer string including terminating zero if requested. |
| Result := (Size <= Length(FData)+1); |
| if (Result) then |
| Move(PChar(FData)^, Value^, Size); |
| end; |
| function TCustomStringClipboardFormat.GetSize: integer; |
| begin |
| Result := Length(FData); |
| end; |
| function TCustomStringClipboardFormat.GetString: string; |
| begin |
| Result := FData; |
| end; |
| procedure TCustomStringClipboardFormat.SetString(const Value: string); |
| begin |
| FData := Value; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomStringListClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TCustomStringListClipboardFormat.Create; |
| begin |
| inherited Create; |
| FLines := TStringList.Create |
| end; |
| destructor TCustomStringListClipboardFormat.Destroy; |
| begin |
| FLines.Free; |
| inherited Destroy; |
| end; |
| procedure TCustomStringListClipboardFormat.Clear; |
| begin |
| FLines.Clear; |
| end; |
| function TCustomStringListClipboardFormat.HasData: boolean; |
| begin |
| Result := (FLines.Count > 0); |
| end; |
| function TCustomStringListClipboardFormat.ReadData(Value: pointer; |
| Size: integer): boolean; |
| var |
| s : string; |
| begin |
| SetLength(s, Size+1); |
| Move(Value^, PChar(s)^, Size); |
| s[Size] := #0; |
| FLines.Text := s; |
| Result := True; |
| end; |
| function TCustomStringListClipboardFormat.WriteData(Value: pointer; |
| Size: integer): boolean; |
| var |
| s : string; |
| begin |
| s := FLines.Text; |
| Result := (Size = Length(s)+1); |
| if (Result) then |
| Move(PChar(s)^, Value^, Size); |
| end; |
| function TCustomStringListClipboardFormat.GetSize: integer; |
| begin |
| Result := Length(FLines.Text)+1; |
| end; |
| function TCustomStringListClipboardFormat.GetLines: TStrings; |
| begin |
| Result := FLines; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomTextClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TCustomTextClipboardFormat.Create; |
| begin |
| inherited Create; |
| TrimZeroes := True; |
| end; |
| function TCustomTextClipboardFormat.GetSize: integer; |
| begin |
| Result := inherited GetSize; |
| // Unless the data is already zero terminated, we add a byte to include |
| // the string's implicit terminating zero. |
| if (Data[Result] <> #0) then |
| inc(Result); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomWideTextClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure TCustomWideTextClipboardFormat.Clear; |
| begin |
| FText := ''; |
| end; |
| function TCustomWideTextClipboardFormat.HasData: boolean; |
| begin |
| Result := (FText <> ''); |
| end; |
| function TCustomWideTextClipboardFormat.ReadData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| SetLength(FText, Size div 2); |
| Move(Value^, PWideChar(FText)^, Size); |
| Result := True; |
| end; |
| function TCustomWideTextClipboardFormat.WriteData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| Result := (Size <= (Length(FText)+1)*2); |
| if (Result) then |
| Move(PWideChar(FText)^, Value^, Size); |
| end; |
| function TCustomWideTextClipboardFormat.GetSize: integer; |
| begin |
| Result := Length(FText)*2; |
| // Unless the data is already zero terminated, we add two bytes to include |
| // the string's implicit terminating zero. |
| if (FText[Result] <> #0) then |
| inc(Result, 2); |
| end; |
| function TCustomWideTextClipboardFormat.GetText: WideString; |
| begin |
| Result := FText; |
| end; |
| procedure TCustomWideTextClipboardFormat.SetText(const Value: WideString); |
| begin |
| FText := Value; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TTextClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TTextClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| Result := CF_TEXT; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomDWORDClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TCustomDWORDClipboardFormat.ReadData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| FValue := PDWORD(Value)^; |
| Result := True; |
| end; |
| function TCustomDWORDClipboardFormat.WriteData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| Result := (Size = SizeOf(DWORD)); |
| if (Result) then |
| PDWORD(Value)^ := FValue; |
| end; |
| function TCustomDWORDClipboardFormat.GetSize: integer; |
| begin |
| Result := SizeOf(DWORD); |
| end; |
| procedure TCustomDWORDClipboardFormat.Clear; |
| begin |
| FValue := 0; |
| end; |
| function TCustomDWORDClipboardFormat.GetValueDWORD: DWORD; |
| begin |
| Result := FValue; |
| end; |
| procedure TCustomDWORDClipboardFormat.SetValueDWORD(Value: DWORD); |
| begin |
| FValue := Value; |
| end; |
| function TCustomDWORDClipboardFormat.GetValueInteger: integer; |
| begin |
| Result := integer(FValue); |
| end; |
| procedure TCustomDWORDClipboardFormat.SetValueInteger(Value: integer); |
| begin |
| FValue := DWORD(Value); |
| end; |
| function TCustomDWORDClipboardFormat.GetValueLongInt: longInt; |
| begin |
| Result := longInt(FValue); |
| end; |
| procedure TCustomDWORDClipboardFormat.SetValueLongInt(Value: longInt); |
| begin |
| FValue := DWORD(Value); |
| end; |
| function TCustomDWORDClipboardFormat.GetValueBoolean: boolean; |
| begin |
| Result := (FValue <> 0); |
| end; |
| procedure TCustomDWORDClipboardFormat.SetValueBoolean(Value: boolean); |
| begin |
| FValue := ord(Value); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileGroupDescritorClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_FILEGROUPDESCRIPTOR: TClipFormat = 0; |
| function TFileGroupDescritorClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_FILEGROUPDESCRIPTOR = 0) then |
| CF_FILEGROUPDESCRIPTOR := RegisterClipboardFormat(CFSTR_FILEDESCRIPTOR); |
| Result := CF_FILEGROUPDESCRIPTOR; |
| end; |
| destructor TFileGroupDescritorClipboardFormat.Destroy; |
| begin |
| Clear; |
| inherited Destroy; |
| end; |
| procedure TFileGroupDescritorClipboardFormat.Clear; |
| begin |
| if (FFileGroupDescriptor <> nil) then |
| begin |
| FreeMem(FFileGroupDescriptor); |
| FFileGroupDescriptor := nil; |
| end; |
| end; |
| function TFileGroupDescritorClipboardFormat.HasData: boolean; |
| begin |
| Result := (FFileGroupDescriptor <> nil) and (FFileGroupDescriptor^.cItems <> 0); |
| end; |
| procedure TFileGroupDescritorClipboardFormat.CopyFrom(AFileGroupDescriptor: PFileGroupDescriptor); |
| var |
| Size : integer; |
| begin |
| Clear; |
| if (AFileGroupDescriptor <> nil) then |
| begin |
| Size := SizeOf(UINT) + AFileGroupDescriptor^.cItems * SizeOf(TFileDescriptor); |
| GetMem(FFileGroupDescriptor, Size); |
| Move(AFileGroupDescriptor^, FFileGroupDescriptor^, Size); |
| end; |
| end; |
| function TFileGroupDescritorClipboardFormat.GetSize: integer; |
| begin |
| if (FFileGroupDescriptor <> nil) then |
| Result := SizeOf(UINT) + FFileGroupDescriptor^.cItems * SizeOf(TFileDescriptor) |
| else |
| Result := 0; |
| end; |
| function TFileGroupDescritorClipboardFormat.ReadData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| // Validate size against count |
| Result := |
| (Size - SizeOf(UINT)) DIV SizeOf(TFileDescriptor) = integer(PFileGroupDescriptor(Value)^.cItems); |
| if (Result) then |
| CopyFrom(PFileGroupDescriptor(Value)); |
| end; |
| function TFileGroupDescritorClipboardFormat.WriteData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| // Validate size against count |
| Result := (FFileGroupDescriptor <> nil) and |
| ((Size - SizeOf(UINT)) DIV SizeOf(TFileDescriptor) = integer(FFileGroupDescriptor^.cItems)); |
| if (Result) then |
| Move(FFileGroupDescriptor^, Value^, Size); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileGroupDescritorWClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_FILEGROUPDESCRIPTORW: TClipFormat = 0; |
| function TFileGroupDescritorWClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_FILEGROUPDESCRIPTORW = 0) then |
| CF_FILEGROUPDESCRIPTORW := RegisterClipboardFormat(CFSTR_FILEDESCRIPTORW); |
| Result := CF_FILEGROUPDESCRIPTORW; |
| end; |
| destructor TFileGroupDescritorWClipboardFormat.Destroy; |
| begin |
| Clear; |
| inherited Destroy; |
| end; |
| procedure TFileGroupDescritorWClipboardFormat.Clear; |
| begin |
| if (FFileGroupDescriptor <> nil) then |
| begin |
| FreeMem(FFileGroupDescriptor); |
| FFileGroupDescriptor := nil; |
| end; |
| end; |
| function TFileGroupDescritorWClipboardFormat.HasData: boolean; |
| begin |
| Result := (FFileGroupDescriptor <> nil) and (FFileGroupDescriptor^.cItems <> 0); |
| end; |
| procedure TFileGroupDescritorWClipboardFormat.CopyFrom(AFileGroupDescriptor: PFileGroupDescriptorW); |
| var |
| Size : integer; |
| begin |
| Clear; |
| if (AFileGroupDescriptor <> nil) then |
| begin |
| Size := SizeOf(UINT) + AFileGroupDescriptor^.cItems * SizeOf(TFileDescriptorW); |
| GetMem(FFileGroupDescriptor, Size); |
| Move(AFileGroupDescriptor^, FFileGroupDescriptor^, Size); |
| end; |
| end; |
| function TFileGroupDescritorWClipboardFormat.GetSize: integer; |
| begin |
| if (FFileGroupDescriptor <> nil) then |
| Result := SizeOf(UINT) + FFileGroupDescriptor^.cItems * SizeOf(TFileDescriptorW) |
| else |
| Result := 0; |
| end; |
| function TFileGroupDescritorWClipboardFormat.ReadData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| // Validate size against count |
| Result := |
| (Size - SizeOf(UINT)) DIV SizeOf(TFileDescriptorW) = integer(PFileGroupDescriptor(Value)^.cItems); |
| if (Result) then |
| CopyFrom(PFileGroupDescriptorW(Value)); |
| end; |
| function TFileGroupDescritorWClipboardFormat.WriteData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| // Validate size against count |
| Result := (FFileGroupDescriptor <> nil) and |
| ((Size - SizeOf(UINT)) DIV SizeOf(TFileDescriptorW) = integer(FFileGroupDescriptor^.cItems)); |
| if (Result) then |
| Move(FFileGroupDescriptor^, Value^, Size); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileContentsClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_FILECONTENTS: TClipFormat = 0; |
| constructor TFileContentsClipboardFormat.Create; |
| begin |
| inherited Create; |
| FFormatEtc.lindex := 0; |
| end; |
| function TFileContentsClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_FILECONTENTS = 0) then |
| CF_FILECONTENTS := RegisterClipboardFormat(CFSTR_FILECONTENTS); |
| Result := CF_FILECONTENTS; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileContentsStreamClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TFileContentsStreamClipboardFormat.Create; |
| begin |
| CreateFormat(TYMED_ISTREAM); |
| FStreams := TStreamList.Create; |
| end; |
| destructor TFileContentsStreamClipboardFormat.Destroy; |
| begin |
| Clear; |
| FStreams.Free; |
| inherited Destroy; |
| end; |
| function TFileContentsStreamClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_FILECONTENTS = 0) then |
| CF_FILECONTENTS := RegisterClipboardFormat(CFSTR_FILECONTENTS); |
| Result := CF_FILECONTENTS; |
| end; |
| procedure TFileContentsStreamClipboardFormat.Clear; |
| begin |
| FStreams.Clear; |
| end; |
| function TFileContentsStreamClipboardFormat.HasData: boolean; |
| begin |
| Result := (FStreams.Count > 0); |
| end; |
| function TFileContentsStreamClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean; |
| begin |
| Result := True; |
| if (Dest is TDataStreamDataFormat) then |
| begin |
| TDataStreamDataFormat(Dest).Streams.Assign(Streams); |
| end else |
| Result := inherited AssignTo(Dest); |
| end; |
| {$IFOPT R+} |
| {$DEFINE R_PLUS} |
| {$RANGECHECKS OFF} |
| {$ENDIF} |
| function TFileContentsStreamClipboardFormat.GetData(DataObject: IDataObject): boolean; |
| var |
| FGD: TFileGroupDescritorClipboardFormat; |
| Count: integer; |
| Medium: TStgMedium; |
| Stream: IStream; |
| Name: string; |
| MemStream: TMemoryStream; |
| StatStg: TStatStg; |
| Size: longInt; |
| Remaining: longInt; |
| pChunk: PChar; |
| begin |
| Result := False; |
| Clear; |
| FGD := TFileGroupDescritorClipboardFormat.Create; |
| try |
| if (FGD.GetData(DataObject)) then |
| begin |
| // Multiple objects, retrieve one at a time |
| Count := FGD.FileGroupDescriptor^.cItems; |
| FFormatEtc.lindex := 0; |
| end else |
| begin |
| // Single object, retrieve "all" at once |
| Count := 0; |
| FFormatEtc.lindex := -1; |
| Name := ''; |
| end; |
| while (FFormatEtc.lindex < Count) do |
| begin |
| if (DataObject.GetData(FormatEtc, Medium) <> S_OK) then |
| break; |
| try |
| inc(FFormatEtc.lindex); |
| if (Medium.tymed <> TYMED_ISTREAM) then |
| continue; |
| Stream := IStream(Medium.stm); |
| Stream.Stat(StatStg, STATFLAG_NONAME); |
| MemStream := TMemoryStream.Create; |
| try |
| Remaining := StatStg.cbSize; |
| MemStream.Size := Remaining; |
| pChunk := MemStream.Memory; |
| while (Remaining > 0) do |
| begin |
| if (Stream.Read(pChunk, Remaining, @Size) <> S_OK) or |
| (Size = 0) then |
| break; |
| inc(pChunk, Size); |
| dec(Remaining, Size); |
| end; |
| if (FFormatEtc.lindex > 0) then |
| Name := FGD.FileGroupDescriptor^.fgd[FFormatEtc.lindex-1].cFileName; |
| Streams.AddNamed(MemStream, Name); |
| except |
| MemStream.Free; |
| raise; |
| end; |
| Stream := nil; |
| Result := True; |
| finally |
| ReleaseStgMedium(Medium); |
| end; |
| end; |
| finally |
| FGD.Free; |
| end; |
| end; |
| {$IFDEF R_PLUS} |
| {$RANGECHECKS ON} |
| {$UNDEF R_PLUS} |
| {$ENDIF} |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileContentsStreamOnDemandClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TFileContentsStreamOnDemandClipboardFormat.Create; |
| begin |
| CreateFormat(TYMED_ISTREAM); |
| end; |
| destructor TFileContentsStreamOnDemandClipboardFormat.Destroy; |
| begin |
| Clear; |
| inherited Destroy; |
| end; |
| function TFileContentsStreamOnDemandClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_FILECONTENTS = 0) then |
| CF_FILECONTENTS := RegisterClipboardFormat(CFSTR_FILECONTENTS); |
| Result := CF_FILECONTENTS; |
| end; |
| procedure TFileContentsStreamOnDemandClipboardFormat.Clear; |
| begin |
| FGotData := False; |
| FDataRequested := False; |
| end; |
| function TFileContentsStreamOnDemandClipboardFormat.HasData: boolean; |
| begin |
| Result := FGotData or FDataRequested; |
| end; |
| function TFileContentsStreamOnDemandClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean; |
| begin |
| if (Dest is TVirtualFileStreamDataFormat) then |
| begin |
| Result := True |
| end else |
| Result := inherited AssignTo(Dest); |
| end; |
| function TFileContentsStreamOnDemandClipboardFormat.Assign( |
| Source: TCustomDataFormat): boolean; |
| begin |
| if (Source is TVirtualFileStreamDataFormat) then |
| begin |
| // Acknowledge that we can offer the requested data, but defer the actual |
| // data transfer. |
| FDataRequested := True; |
| Result := True |
| end else |
| Result := inherited Assign(Source); |
| end; |
| function TFileContentsStreamOnDemandClipboardFormat.DoSetData( |
| const FormatEtcIn: TFormatEtc; var AMedium: TStgMedium): boolean; |
| var |
| Stream : IStream; |
| begin |
| if (Assigned(FOnGetStream)) and (FormatEtcIn.tymed and TYMED_ISTREAM <> 0) and |
| (FormatEtcIn.lindex <> -1) then |
| begin |
| FOnGetStream(Self, FormatEtcIn.lindex, Stream); |
| if (Stream <> nil) then |
| begin |
| IStream(AMedium.stm) := Stream; |
| AMedium.tymed := TYMED_ISTREAM; |
| Result := True; |
| end else |
| Result := False; |
| end else |
| Result := False; |
| end; |
| function TFileContentsStreamOnDemandClipboardFormat.GetData(DataObject: IDataObject): boolean; |
| begin |
| // Flag that data has been offered to us, but defer the actual data transfer. |
| FGotData := True; |
| Result := True; |
| end; |
| function TFileContentsStreamOnDemandClipboardFormat.GetStream(Index: integer): IStream; |
| var |
| Medium : TStgMedium; |
| begin |
| Result := nil; |
| FFormatEtc.lindex := Index; |
| // Get an IStream interface from the source. |
| if ((DataFormat.Owner as TCustomDroptarget).DataObject.GetData(FormatEtc, |
| Medium) = S_OK) and (Medium.tymed = TYMED_ISTREAM) then |
| try |
| Result := IStream(Medium.stm); |
| finally |
| ReleaseStgMedium(Medium); |
| end; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileContentsStorageClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TFileContentsStorageClipboardFormat.Create; |
| begin |
| CreateFormat(TYMED_ISTORAGE); |
| FStorages := TStorageInterfaceList.Create; |
| end; |
| destructor TFileContentsStorageClipboardFormat.Destroy; |
| begin |
| Clear; |
| FStorages.Free; |
| inherited Destroy; |
| end; |
| function TFileContentsStorageClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_FILECONTENTS = 0) then |
| CF_FILECONTENTS := RegisterClipboardFormat(CFSTR_FILECONTENTS); |
| Result := CF_FILECONTENTS; |
| end; |
| procedure TFileContentsStorageClipboardFormat.Clear; |
| begin |
| FStorages.Clear; |
| end; |
| function TFileContentsStorageClipboardFormat.HasData: boolean; |
| begin |
| Result := (FStorages.Count > 0); |
| end; |
| function TFileContentsStorageClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean; |
| begin |
| (* |
| Result := True; |
| if (Dest is TDataStreamDataFormat) then |
| begin |
| TDataStreamDataFormat(Dest).Streams.Assign(Streams); |
| end else |
| *) |
| Result := inherited AssignTo(Dest); |
| end; |
| {$IFOPT R+} |
| {$DEFINE R_PLUS} |
| {$RANGECHECKS OFF} |
| {$ENDIF} |
| function TFileContentsStorageClipboardFormat.GetData(DataObject: IDataObject): boolean; |
| var |
| FGD : TFileGroupDescritorClipboardFormat; |
| Count : integer; |
| Medium : TStgMedium; |
| Storage : IStorage; |
| Name : string; |
| begin |
| Result := False; |
| Clear; |
| FGD := TFileGroupDescritorClipboardFormat.Create; |
| try |
| if (FGD.GetData(DataObject)) then |
| begin |
| // Multiple objects, retrieve one at a time |
| Count := FGD.FileGroupDescriptor^.cItems; |
| FFormatEtc.lindex := 0; |
| end else |
| begin |
| // Single object, retrieve "all" at once |
| Count := 0; |
| FFormatEtc.lindex := -1; |
| Name := ''; |
| end; |
| while (FFormatEtc.lindex < Count) do |
| begin |
| if (DataObject.GetData(FormatEtc, Medium) <> S_OK) then |
| break; |
| try |
| inc(FFormatEtc.lindex); |
| if (Medium.tymed <> TYMED_ISTORAGE) then |
| continue; |
| Storage := IStorage(Medium.stg); |
| if (FFormatEtc.lindex > 0) then |
| Name := FGD.FileGroupDescriptor^.fgd[FFormatEtc.lindex-1].cFileName; |
| Storages.AddNamed(Storage, Name); |
| Storage := nil; |
| Result := True; |
| finally |
| ReleaseStgMedium(Medium); |
| end; |
| end; |
| finally |
| FGD.Free; |
| end; |
| end; |
| {$IFDEF R_PLUS} |
| {$RANGECHECKS ON} |
| {$UNDEF R_PLUS} |
| {$ENDIF} |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TPreferredDropEffectClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_PREFERREDDROPEFFECT: TClipFormat = 0; |
| // GetClassClipboardFormat is used by TCustomDropTarget.GetPreferredDropEffect |
| class function TPreferredDropEffectClipboardFormat.GetClassClipboardFormat: TClipFormat; |
| begin |
| if (CF_PREFERREDDROPEFFECT = 0) then |
| CF_PREFERREDDROPEFFECT := RegisterClipboardFormat(CFSTR_PREFERREDDROPEFFECT); |
| Result := CF_PREFERREDDROPEFFECT; |
| end; |
| function TPreferredDropEffectClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| Result := GetClassClipboardFormat; |
| end; |
| function TPreferredDropEffectClipboardFormat.HasData: boolean; |
| begin |
| Result := True; //(Value <> DROPEFFECT_NONE); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TPerformedDropEffectClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_PERFORMEDDROPEFFECT: TClipFormat = 0; |
| function TPerformedDropEffectClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_PERFORMEDDROPEFFECT = 0) then |
| CF_PERFORMEDDROPEFFECT := RegisterClipboardFormat(CFSTR_PERFORMEDDROPEFFECT); |
| Result := CF_PERFORMEDDROPEFFECT; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TLogicalPerformedDropEffectClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_LOGICALPERFORMEDDROPEFFECT: TClipFormat = 0; |
| function TLogicalPerformedDropEffectClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_LOGICALPERFORMEDDROPEFFECT = 0) then |
| CF_LOGICALPERFORMEDDROPEFFECT := RegisterClipboardFormat('Logical Performed DropEffect'); // *** DO NOT LOCALIZE *** |
| Result := CF_LOGICALPERFORMEDDROPEFFECT; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TPasteSuccededClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_PASTESUCCEEDED: TClipFormat = 0; |
| function TPasteSuccededClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_PASTESUCCEEDED = 0) then |
| CF_PASTESUCCEEDED := RegisterClipboardFormat(CFSTR_PASTESUCCEEDED); |
| Result := CF_PASTESUCCEEDED; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TInShellDragLoopClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_InDragLoop: TClipFormat = 0; |
| function TInShellDragLoopClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_InDragLoop = 0) then |
| CF_InDragLoop := RegisterClipboardFormat(CFSTR_InDragLoop); |
| Result := CF_InDragLoop; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TTargetCLSIDClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure TTargetCLSIDClipboardFormat.Clear; |
| begin |
| FCLSID := GUID_NULL; |
| end; |
| var |
| CF_TargetCLSID: TClipFormat = 0; |
| function TTargetCLSIDClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_TargetCLSID = 0) then |
| CF_TargetCLSID := RegisterClipboardFormat('TargetCLSID'); // *** DO NOT LOCALIZE *** |
| Result := CF_TargetCLSID; |
| end; |
| function TTargetCLSIDClipboardFormat.GetSize: integer; |
| begin |
| Result := SizeOf(TCLSID); |
| end; |
| function TTargetCLSIDClipboardFormat.HasData: boolean; |
| begin |
| Result := not IsEqualCLSID(FCLSID, GUID_NULL); |
| end; |
| function TTargetCLSIDClipboardFormat.ReadData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| // Validate size. |
| Result := (Size = SizeOf(TCLSID)); |
| if (Result) then |
| FCLSID := PCLSID(Value)^; |
| end; |
| function TTargetCLSIDClipboardFormat.WriteData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| // Validate size. |
| Result := (Size = SizeOf(TCLSID)); |
| if (Result) then |
| PCLSID(Value)^ := FCLSID; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TTextDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TTextDataFormat.Assign(Source: TClipboardFormat): boolean; |
| begin |
| Result := True; |
| if (Source is TTextClipboardFormat) then |
| FText := TTextClipboardFormat(Source).Text |
| else if (Source is TFileContentsClipboardFormat) then |
| FText := TFileContentsClipboardFormat(Source).Data |
| else |
| Result := inherited Assign(Source); |
| end; |
| function TTextDataFormat.AssignTo(Dest: TClipboardFormat): boolean; |
| var |
| FGD: TFileGroupDescriptor; |
| FGDW: TFileGroupDescriptorW; |
| resourcestring |
| // Name of the text scrap file. |
| sTextScrap = 'Text scrap.txt'; |
| begin |
| Result := True; |
| if (Dest is TTextClipboardFormat) then |
| TTextClipboardFormat(Dest).Text := FText |
| else if (Dest is TFileContentsClipboardFormat) then |
| TFileContentsClipboardFormat(Dest).Data := FText |
| else if (Dest is TFileGroupDescritorClipboardFormat) then |
| begin |
| FillChar(FGD, SizeOf(FGD), 0); |
| FGD.cItems := 1; |
| StrPLCopy(FGD.fgd[0].cFileName, sTextScrap, SizeOf(FGD.fgd[0].cFileName)); |
| TFileGroupDescritorClipboardFormat(Dest).CopyFrom(@FGD); |
| end else |
| if (Dest is TFileGroupDescritorWClipboardFormat) then |
| begin |
| FillChar(FGDW, SizeOf(FGDW), 0); |
| FGDW.cItems := 1; |
| StringToWideChar(sTextScrap, PWideChar(@(FGDW.fgd[0].cFileName)), MAX_PATH); |
| TFileGroupDescritorWClipboardFormat(Dest).CopyFrom(@FGDW); |
| end else |
| Result := inherited AssignTo(Dest); |
| end; |
| procedure TTextDataFormat.Clear; |
| begin |
| Changing; |
| FText := ''; |
| end; |
| procedure TTextDataFormat.SetText(const Value: string); |
| begin |
| Changing; |
| FText := Value; |
| end; |
| function TTextDataFormat.HasData: boolean; |
| begin |
| Result := (FText <> ''); |
| end; |
| function TTextDataFormat.NeedsData: boolean; |
| begin |
| Result := (FText = ''); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDataStreamDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDataStreamDataFormat.Create(AOwner: TDragDropComponent); |
| begin |
| inherited Create(AOwner); |
| FStreams := TStreamList.Create; |
| FStreams.OnChanging := DoOnChanging; |
| end; |
| destructor TDataStreamDataFormat.Destroy; |
| begin |
| Clear; |
| FStreams.Free; |
| inherited Destroy; |
| end; |
| procedure TDataStreamDataFormat.Clear; |
| begin |
| Changing; |
| FStreams.Clear; |
| end; |
| function TDataStreamDataFormat.HasData: boolean; |
| begin |
| Result := (Streams.Count > 0); |
| end; |
| function TDataStreamDataFormat.NeedsData: boolean; |
| begin |
| Result := (Streams.Count = 0); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFileDescriptorToFilenameStrings |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Used internally to convert between FileDescriptors and filenames on-demand. |
| //////////////////////////////////////////////////////////////////////////////// |
| type |
| TFileDescriptorToFilenameStrings = class(TStrings) |
| private |
| FFileDescriptors: TMemoryList; |
| protected |
| function Get(Index: Integer): string; override; |
| function GetCount: Integer; override; |
| public |
| constructor Create(AFileDescriptors: TMemoryList); |
| procedure Clear; override; |
| procedure Delete(Index: Integer); override; |
| procedure Insert(Index: Integer; const S: string); override; |
| procedure Assign(Source: TPersistent); override; |
| end; |
| constructor TFileDescriptorToFilenameStrings.Create(AFileDescriptors: TMemoryList); |
| begin |
| inherited Create; |
| FFileDescriptors := AFileDescriptors; |
| end; |
| function TFileDescriptorToFilenameStrings.Get(Index: Integer): string; |
| begin |
| Result := PFileDescriptor(FFileDescriptors[Index]).cFileName; |
| end; |
| function TFileDescriptorToFilenameStrings.GetCount: Integer; |
| begin |
| Result := FFileDescriptors.Count; |
| end; |
| procedure TFileDescriptorToFilenameStrings.Assign(Source: TPersistent); |
| var |
| i: integer; |
| begin |
| if Source is TStrings then |
| begin |
| BeginUpdate; |
| try |
| FFileDescriptors.Clear; |
| for i := 0 to TStrings(Source).Count-1 do |
| Add(TStrings(Source)[i]); |
| finally |
| EndUpdate; |
| end; |
| end else |
| inherited Assign(Source); |
| end; |
| procedure TFileDescriptorToFilenameStrings.Clear; |
| begin |
| FFileDescriptors.Clear; |
| end; |
| procedure TFileDescriptorToFilenameStrings.Delete(Index: Integer); |
| begin |
| FFileDescriptors.Delete(Index); |
| end; |
| procedure TFileDescriptorToFilenameStrings.Insert(Index: Integer; const S: string); |
| var |
| FD: PFileDescriptor; |
| begin |
| if (Index = FFileDescriptors.Count) then |
| begin |
| GetMem(FD, SizeOf(TFileDescriptor)); |
| try |
| FillChar(FD^, SizeOf(TFileDescriptor), 0); |
| StrPLCopy(FD.cFileName, S, SizeOf(FD.cFileName)); |
| FFileDescriptors.Add(FD); |
| except |
| FreeMem(FD); |
| raise; |
| end; |
| end; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TVirtualFileStreamDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TVirtualFileStreamDataFormat.Create(AOwner: TDragDropComponent); |
| begin |
| inherited Create(AOwner); |
| FFileDescriptors := TMemoryList.Create; |
| FFileNames := TFileDescriptorToFilenameStrings.Create(FFileDescriptors); |
| // Add the "file group descriptor" and "file contents" clipboard formats to |
| // the data format's list of compatible formats. |
| // Note: This is normally done via TCustomDataFormat.RegisterCompatibleFormat, |
| // but since this data format and the clipboard format class are specialized |
| // to be used with each other, it is just as easy for us to add the formats |
| // manually. |
| FFileContentsClipboardFormat := TFileContentsStreamOnDemandClipboardFormat.Create; |
| CompatibleFormats.Add(FFileContentsClipboardFormat); |
| FFileGroupDescritorClipboardFormat := TFileGroupDescritorClipboardFormat.Create; |
| // Normaly TFileGroupDescritorClipboardFormat supports both HGlobal and |
| // IStream storage medium transfers, but for this demo we only use IStream. |
| // FFileGroupDescritorClipboardFormat.FormatEtc.tymed := TYMED_ISTREAM; |
| CompatibleFormats.Add(FFileGroupDescritorClipboardFormat); |
| end; |
| destructor TVirtualFileStreamDataFormat.Destroy; |
| begin |
| FFileDescriptors.Free; |
| FFileNames.Free; |
| inherited Destroy; |
| end; |
| procedure TVirtualFileStreamDataFormat.SetFileNames(const Value: TStrings); |
| begin |
| FFileNames.Assign(Value); |
| end; |
| {$IFOPT R+} |
| {$DEFINE R_PLUS} |
| {$RANGECHECKS OFF} |
| {$ENDIF} |
| function TVirtualFileStreamDataFormat.Assign(Source: TClipboardFormat): boolean; |
| var |
| i: integer; |
| FD: PFileDescriptor; |
| begin |
| Result := True; |
| (* |
| ** TFileContentsStreamOnDemandClipboardFormat |
| *) |
| if (Source is TFileContentsStreamOnDemandClipboardFormat) then |
| begin |
| FHasContents := TFileContentsStreamOnDemandClipboardFormat(Source).HasData; |
| end else |
| (* |
| ** TFileGroupDescritorClipboardFormat |
| *) |
| if (Source is TFileGroupDescritorClipboardFormat) then |
| begin |
| FFileDescriptors.Clear; |
| for i := 0 to TFileGroupDescritorClipboardFormat(Source).FileGroupDescriptor^.cItems-1 do |
| begin |
| GetMem(FD, SizeOf(TFileDescriptor)); |
| try |
| Move(TFileGroupDescritorClipboardFormat(Source).FileGroupDescriptor^.fgd[i], |
| FD^, SizeOf(TFileDescriptor)); |
| FFileDescriptors.Add(FD); |
| except |
| FreeMem(FD); |
| raise; |
| end; |
| end; |
| end else |
| (* |
| ** None of the above... |
| *) |
| Result := inherited Assign(Source); |
| end; |
| {$IFDEF R_PLUS} |
| {$RANGECHECKS ON} |
| {$UNDEF R_PLUS} |
| {$ENDIF} |
| {$IFOPT R+} |
| {$DEFINE R_PLUS} |
| {$RANGECHECKS OFF} |
| {$ENDIF} |
| function TVirtualFileStreamDataFormat.AssignTo(Dest: TClipboardFormat): boolean; |
| var |
| FGD: PFileGroupDescriptor; |
| i: integer; |
| begin |
| (* |
| ** TFileContentsStreamOnDemandClipboardFormat |
| *) |
| if (Dest is TFileContentsStreamOnDemandClipboardFormat) then |
| begin |
| // Let the clipboard format handle the transfer. |
| // No data is actually transferred, but TFileContentsStreamOnDemandClipboardFormat |
| // needs to set a flag when data is requested. |
| Result := Dest.Assign(Self); |
| end else |
| (* |
| ** TFileGroupDescritorClipboardFormat |
| *) |
| if (Dest is TFileGroupDescritorClipboardFormat) then |
| begin |
| if (FFileDescriptors.Count > 0) then |
| begin |
| GetMem(FGD, SizeOf(UINT) + FFileDescriptors.Count * SizeOf(TFileDescriptor)); |
| try |
| FGD.cItems := FFileDescriptors.Count; |
| for i := 0 to FFileDescriptors.Count-1 do |
| Move(FFileDescriptors[i]^, FGD.fgd[i], SizeOf(TFileDescriptor)); |
| TFileGroupDescritorClipboardFormat(Dest).CopyFrom(FGD); |
| finally |
| FreeMem(FGD); |
| end; |
| Result := True; |
| end else |
| Result := False; |
| end else |
| (* |
| ** None of the above... |
| *) |
| Result := inherited AssignTo(Dest); |
| end; |
| {$IFDEF R_PLUS} |
| {$RANGECHECKS ON} |
| {$UNDEF R_PLUS} |
| {$ENDIF} |
| procedure TVirtualFileStreamDataFormat.Clear; |
| begin |
| FFileDescriptors.Clear; |
| FHasContents := False; |
| end; |
| function TVirtualFileStreamDataFormat.HasData: boolean; |
| begin |
| Result := (FFileDescriptors.Count > 0) and |
| ((FHasContents) or Assigned(FFileContentsClipboardFormat.OnGetStream)); |
| end; |
| function TVirtualFileStreamDataFormat.NeedsData: boolean; |
| begin |
| Result := (FFileDescriptors.Count = 0) or (not FHasContents); |
| end; |
| function TVirtualFileStreamDataFormat.GetOnGetStream: TOnGetStreamEvent; |
| begin |
| Result := FFileContentsClipboardFormat.OnGetStream; |
| end; |
| procedure TVirtualFileStreamDataFormat.SetOnGetStream(const Value: TOnGetStreamEvent); |
| begin |
| FFileContentsClipboardFormat.OnGetStream := Value; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TFeedbackDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TFeedbackDataFormat.Assign(Source: TClipboardFormat): boolean; |
| begin |
| Result := True; |
| if (Source is TPreferredDropEffectClipboardFormat) then |
| FPreferredDropEffect := TPreferredDropEffectClipboardFormat(Source).Value |
| else if (Source is TPerformedDropEffectClipboardFormat) then |
| FPerformedDropEffect := TPerformedDropEffectClipboardFormat(Source).Value |
| else if (Source is TLogicalPerformedDropEffectClipboardFormat) then |
| FLogicalPerformedDropEffect := TLogicalPerformedDropEffectClipboardFormat(Source).Value |
| else if (Source is TPasteSuccededClipboardFormat) then |
| FPasteSucceded := TPasteSuccededClipboardFormat(Source).Value |
| else if (Source is TTargetCLSIDClipboardFormat) then |
| FTargetCLSID := TTargetCLSIDClipboardFormat(Source).CLSID |
| else if (Source is TInShellDragLoopClipboardFormat) then |
| begin |
| FInShellDragLoop := TInShellDragLoopClipboardFormat(Source).InShellDragLoop; |
| FGotInShellDragLoop := True; |
| end else |
| Result := inherited Assign(Source); |
| end; |
| function TFeedbackDataFormat.AssignTo(Dest: TClipboardFormat): boolean; |
| begin |
| Result := True; |
| if (Dest is TPreferredDropEffectClipboardFormat) then |
| TPreferredDropEffectClipboardFormat(Dest).Value := FPreferredDropEffect |
| else if (Dest is TPerformedDropEffectClipboardFormat) then |
| TPerformedDropEffectClipboardFormat(Dest).Value := FPerformedDropEffect |
| else if (Dest is TLogicalPerformedDropEffectClipboardFormat) then |
| TLogicalPerformedDropEffectClipboardFormat(Dest).Value := FLogicalPerformedDropEffect |
| else if (Dest is TPasteSuccededClipboardFormat) then |
| TPasteSuccededClipboardFormat(Dest).Value := FPasteSucceded |
| else if (Dest is TTargetCLSIDClipboardFormat) then |
| TTargetCLSIDClipboardFormat(Dest).CLSID := FTargetCLSID |
| else if (Dest is TInShellDragLoopClipboardFormat) then |
| TInShellDragLoopClipboardFormat(Dest).InShellDragLoop := FInShellDragLoop |
| else |
| Result := inherited AssignTo(Dest); |
| end; |
| procedure TFeedbackDataFormat.Clear; |
| begin |
| Changing; |
| FPreferredDropEffect := DROPEFFECT_NONE; |
| FPerformedDropEffect := DROPEFFECT_NONE; |
| FInShellDragLoop := False; |
| FGotInShellDragLoop := False; |
| end; |
| procedure TFeedbackDataFormat.SetInShellDragLoop(const Value: boolean); |
| begin |
| Changing; |
| FInShellDragLoop := Value; |
| end; |
| procedure TFeedbackDataFormat.SetPasteSucceded(const Value: longInt); |
| begin |
| Changing; |
| FPasteSucceded := Value; |
| end; |
| procedure TFeedbackDataFormat.SetPerformedDropEffect( |
| const Value: longInt); |
| begin |
| Changing; |
| FPerformedDropEffect := Value; |
| end; |
| procedure TFeedbackDataFormat.SetLogicalPerformedDropEffect( |
| const Value: longInt); |
| begin |
| Changing; |
| FLogicalPerformedDropEffect := Value; |
| end; |
| procedure TFeedbackDataFormat.SetPreferredDropEffect( |
| const Value: longInt); |
| begin |
| Changing; |
| FPreferredDropEffect := Value; |
| end; |
| procedure TFeedbackDataFormat.SetTargetCLSID(const Value: TCLSID); |
| begin |
| Changing; |
| FTargetCLSID := Value; |
| end; |
| function TFeedbackDataFormat.HasData: boolean; |
| begin |
| Result := (FPreferredDropEffect <> DROPEFFECT_NONE) or |
| (FPerformedDropEffect <> DROPEFFECT_NONE) or |
| (FPasteSucceded <> DROPEFFECT_NONE) or |
| (FGotInShellDragLoop); |
| end; |
| function TFeedbackDataFormat.NeedsData: boolean; |
| begin |
| Result := (FPreferredDropEffect = DROPEFFECT_NONE) or |
| (FPerformedDropEffect = DROPEFFECT_NONE) or |
| (FPasteSucceded = DROPEFFECT_NONE) or |
| (not FGotInShellDragLoop); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TGenericClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure TGenericClipboardFormat.SetClipboardFormatName(const Value: string); |
| begin |
| FFormat := Value; |
| if (FFormat <> '') then |
| ClipboardFormat := RegisterClipboardFormat(PChar(FFormat)); |
| end; |
| function TGenericClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (FFormatEtc.cfFormat = 0) and (FFormat <> '') then |
| FFormatEtc.cfFormat := RegisterClipboardFormat(PChar(FFormat)); |
| Result := FFormatEtc.cfFormat; |
| end; |
| function TGenericClipboardFormat.GetClipboardFormatName: string; |
| begin |
| Result := FFormat; |
| end; |
| function TGenericClipboardFormat.Assign(Source: TCustomDataFormat): boolean; |
| begin |
| if (Source is TGenericDataFormat) then |
| begin |
| Data := TGenericDataFormat(Source).Data; |
| Result := True; |
| end else |
| Result := inherited Assign(Source); |
| end; |
| function TGenericClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean; |
| begin |
| if (Dest is TGenericDataFormat) then |
| begin |
| TGenericDataFormat(Dest).Data := Data; |
| Result := True; |
| end else |
| Result := inherited AssignTo(Dest); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TGenericDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure TGenericDataFormat.AddFormat(const AFormat: string); |
| var |
| ClipboardFormat: TGenericClipboardFormat; |
| begin |
| ClipboardFormat := TGenericClipboardFormat.Create; |
| ClipboardFormat.ClipboardFormatName := AFormat; |
| ClipboardFormat.DataDirections := [ddRead]; |
| CompatibleFormats.Add(ClipboardFormat); |
| end; |
| procedure TGenericDataFormat.Clear; |
| begin |
| Changing; |
| FData := ''; |
| end; |
| function TGenericDataFormat.HasData: boolean; |
| begin |
| Result := (FData <> ''); |
| end; |
| function TGenericDataFormat.NeedsData: boolean; |
| begin |
| Result := (FData = ''); |
| end; |
| procedure TGenericDataFormat.DoSetData(const Value: string); |
| begin |
| Changing; |
| FData := Value; |
| end; |
| procedure TGenericDataFormat.SetDataHere(const AData; ASize: integer); |
| begin |
| Changing; |
| SetLength(FData, ASize); |
| Move(AData, PChar(FData)^, ASize); |
| end; |
| function TGenericDataFormat.GetSize: integer; |
| begin |
| Result := length(FData); |
| end; |
| function TGenericDataFormat.GetDataHere(var AData; ASize: integer): integer; |
| begin |
| Result := Size; |
| if (ASize < Result) then |
| Result := ASize; |
| Move(PChar(FData)^, AData, Result); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Initialization/Finalization |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| initialization |
| // Data format registration |
| TTextDataFormat.RegisterDataFormat; |
| TDataStreamDataFormat.RegisterDataFormat; |
| TVirtualFileStreamDataFormat.RegisterDataFormat; |
| // Clipboard format registration |
| TTextDataFormat.RegisterCompatibleFormat(TTextClipboardFormat, 0, csSourceTarget, [ddRead]); |
| TTextDataFormat.RegisterCompatibleFormat(TFileContentsClipboardFormat, 1, csSourceTarget, [ddRead]); |
| TTextDataFormat.RegisterCompatibleFormat(TFileGroupDescritorClipboardFormat, 1, [csSource], [ddRead]); |
| TTextDataFormat.RegisterCompatibleFormat(TFileGroupDescritorWClipboardFormat, 1, [csSource], [ddRead]); |
| TFeedbackDataFormat.RegisterCompatibleFormat(TPreferredDropEffectClipboardFormat, 0, csSourceTarget, [ddRead]); |
| TFeedbackDataFormat.RegisterCompatibleFormat(TPerformedDropEffectClipboardFormat, 0, csSourceTarget, [ddWrite]); |
| TFeedbackDataFormat.RegisterCompatibleFormat(TPasteSuccededClipboardFormat, 0, csSourceTarget, [ddWrite]); |
| TFeedbackDataFormat.RegisterCompatibleFormat(TInShellDragLoopClipboardFormat, 0, csSourceTarget, [ddRead]); |
| TFeedbackDataFormat.RegisterCompatibleFormat(TTargetCLSIDClipboardFormat, 0, csSourceTarget, [ddWrite]); |
| TFeedbackDataFormat.RegisterCompatibleFormat(TLogicalPerformedDropEffectClipboardFormat, 0, csSourceTarget, [ddWrite]); |
| TDataStreamDataFormat.RegisterCompatibleFormat(TFileContentsStreamClipboardFormat, 0, [csTarget], [ddRead]); |
| finalization |
| TTextDataFormat.UnregisterDataFormat; |
| TDataStreamDataFormat.UnregisterDataFormat; |
| TFeedbackDataFormat.UnregisterDataFormat; |
| TVirtualFileStreamDataFormat.UnregisterDataFormat; |
| TTextClipboardFormat.UnregisterClipboardFormat; |
| TFileGroupDescritorClipboardFormat.UnregisterClipboardFormat; |
| TFileGroupDescritorWClipboardFormat.UnregisterClipboardFormat; |
| TFileContentsClipboardFormat.UnregisterClipboardFormat; |
| TFileContentsStreamClipboardFormat.UnregisterClipboardFormat; |
| TPreferredDropEffectClipboardFormat.UnregisterClipboardFormat; |
| TPerformedDropEffectClipboardFormat.UnregisterClipboardFormat; |
| TPasteSuccededClipboardFormat.UnregisterClipboardFormat; |
| TInShellDragLoopClipboardFormat.UnregisterClipboardFormat; |
| TTargetCLSIDClipboardFormat.UnregisterClipboardFormat; |
| TLogicalPerformedDropEffectClipboardFormat.UnregisterClipboardFormat; |
| end. |
| /trunk/VCL_DRAGDROP/DragDropGraphics.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DragDropGraphics.pas |
|---|
| 0,0 → 1,988 |
| unit DragDropGraphics; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite. |
| // Module: DragDropGraphics |
| // Description: Implements Dragging and Dropping of graphic data. |
| // Version: 4.0 |
| // Date: 18-MAY-2001 |
| // Target: Win32, Delphi 5-6 |
| // Authors: Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2001 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DragDrop, |
| DropTarget, |
| DropSource, |
| ActiveX, |
| Windows, |
| Graphics, |
| Classes; |
| {$include DragDrop.inc} |
| type |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TGDIClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Base class for GDI clipboard formats (TYMED_GDI). |
| //////////////////////////////////////////////////////////////////////////////// |
| TGDIClipboardFormat = class(TClipboardFormat) |
| public |
| constructor Create; override; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TPaletteClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Only used internally by TBitmapClipboardFormat - Not registered |
| //////////////////////////////////////////////////////////////////////////////// |
| TPaletteClipboardFormat = class(TGDIClipboardFormat) |
| private |
| FPalette : hPalette; |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| function DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean; override; |
| function DoSetData(const FormatEtcIn: TFormatEtc; |
| var Medium: TStgMedium): boolean; override; |
| procedure Clear; override; |
| property Palette: hPalette read FPalette write FPalette; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomBitmapClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TCustomBitmapClipboardFormat = class(TGDIClipboardFormat) |
| private |
| FBitmap : TBitmap; |
| protected |
| constructor CreateFormat(Atymed: Longint); override; |
| public |
| destructor Destroy; override; |
| procedure Clear; override; |
| property Bitmap: TBitmap read FBitmap; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TBitmapClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TBitmapClipboardFormat = class(TCustomBitmapClipboardFormat) |
| protected |
| function DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean; override; |
| function DoSetData(const FormatEtcIn: TFormatEtc; |
| var AMedium: TStgMedium): boolean; override; |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDIBClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TDIBClipboardFormat = class(TCustomBitmapClipboardFormat) |
| private |
| protected |
| function DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean; override; |
| function DoSetData(const FormatEtcIn: TFormatEtc; |
| var AMedium: TStgMedium): boolean; override; |
| public |
| constructor Create; override; |
| function GetClipboardFormat: TClipFormat; override; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomMetaFileClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TCustomMetaFileClipboardFormat = class(TClipboardFormat) |
| private |
| FMetaFile : TMetaFile; |
| protected |
| public |
| constructor Create; override; |
| destructor Destroy; override; |
| procedure Clear; override; |
| property MetaFile: TMetaFile read FMetaFile; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TMetaFileClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TMetaFileClipboardFormat = class(TCustomMetaFileClipboardFormat) |
| private |
| protected |
| function DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean; override; |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TEnhMetaFileClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TEnhMetaFileClipboardFormat = class(TCustomMetaFileClipboardFormat) |
| private |
| protected |
| function DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean; override; |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TBitmapDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TBitmapDataFormat = class(TCustomDataFormat) |
| private |
| FBitmap : TBitmap; |
| protected |
| public |
| constructor Create(AOwner: TDragDropComponent); override; |
| destructor Destroy; override; |
| function Assign(Source: TClipboardFormat): boolean; override; |
| function AssignTo(Dest: TClipboardFormat): boolean; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function NeedsData: boolean; override; |
| property Bitmap: TBitmap read FBitmap; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TMetaFileDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TMetaFileDataFormat = class(TCustomDataFormat) |
| private |
| FMetaFile : TMetaFile; |
| protected |
| public |
| constructor Create(AOwner: TDragDropComponent); override; |
| destructor Destroy; override; |
| function Assign(Source: TClipboardFormat): boolean; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function NeedsData: boolean; override; |
| property MetaFile: TMetaFile read FMetaFile; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropBMPTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropBMPTarget = class(TCustomDropMultiTarget) |
| private |
| FBitmapFormat : TBitmapDataFormat; |
| protected |
| function GetBitmap: TBitmap; |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; override; |
| property Bitmap: TBitmap read GetBitmap; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropBMPSource |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropBMPSource = class(TCustomDropMultiSource) |
| private |
| FBitmapFormat : TBitmapDataFormat; |
| protected |
| procedure SetBitmap(const Value: TBitmap); |
| function GetBitmap: TBitmap; |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; override; |
| published |
| property Bitmap: TBitmap read GetBitmap write SetBitmap; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropMetaFileTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropMetaFileTarget = class(TCustomDropMultiTarget) |
| private |
| FMetaFileFormat : TMetaFileDataFormat; |
| protected |
| function GetMetaFile: TMetaFile; |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; override; |
| property MetaFile: TMetaFile read GetMetaFile; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropImageTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropImageTarget = class(TCustomDropMultiTarget) |
| private |
| FMetaFileFormat : TMetaFileDataFormat; |
| FBitmapFormat : TBitmapDataFormat; |
| FPicture : TPicture; |
| protected |
| function DoGetData: boolean; override; |
| procedure ClearData; override; |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; override; |
| property Picture: TPicture read FPicture; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Misc. |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure CopyDIBToBitmap(Bitmap: TBitmap; BitmapInfo: PBitmapInfo; DIBSize: integer); |
| function GetHGlobalDIBFromBitmap(Bitmap: TBitmap): HGlobal; |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // IMPLEMENTATION |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| implementation |
| uses |
| SysUtils; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| begin |
| RegisterComponents(DragDropComponentPalettePage, [TDropBMPTarget, |
| TDropBMPSource, TDropMetaFileTarget, TDropImageTarget]); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Misc. |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure CopyDIBToBitmap(Bitmap: TBitmap; BitmapInfo: PBitmapInfo; DIBSize: integer); |
| var |
| BitmapFileHeader : TBitmapFileHeader; |
| FileSize : integer; |
| InfoSize : integer; |
| Stream : TMemoryStream; |
| begin |
| // Write DIB to a stream in the BMP file format |
| Stream := TMemoryStream.Create; |
| try |
| FileSize := sizeof(TBitmapFileHeader) + DIBSize; |
| InfoSize := sizeof(TBitmapInfoHeader); |
| if (BitmapInfo^.bmiHeader.biBitCount > 8) then |
| begin |
| if ((BitmapInfo^.bmiHeader.biCompression and BI_BITFIELDS) <> 0) then |
| Inc(InfoSize, 12); |
| end else |
| Inc(InfoSize, sizeof(TRGBQuad) * (1 shl BitmapInfo^.bmiHeader.biBitCount)); |
| Stream.SetSize(FileSize); |
| // Initialize file header |
| FillChar(BitmapFileHeader, sizeof(TBitmapFileHeader), 0); |
| with BitmapFileHeader do |
| begin |
| bfType := $4D42; // 'BM' = Windows BMP signature |
| bfSize := FileSize; // File size (not needed) |
| bfOffBits := sizeof(TBitmapFileHeader) + InfoSize; // Offset of pixel data |
| end; |
| // Save file header |
| Stream.Write(BitmapFileHeader, sizeof(TBitmapFileHeader)); |
| // Save TBitmapInfo structure and pixel data |
| Stream.Write(BitmapInfo^, DIBSize); |
| // Rewind and load bitmap from stream |
| Stream.Position := 0; |
| Bitmap.LoadFromStream(Stream); |
| finally |
| Stream.Free; |
| end; |
| end; |
| function GetHGlobalDIBFromBitmap(Bitmap: TBitmap): HGlobal; |
| var |
| Stream : TMemoryStream; |
| DIB : pointer; |
| DIBSize : integer; |
| begin |
| Stream := TMemoryStream.Create; |
| try |
| // Write bitmap to a stream and extract the DIB data from it. |
| Bitmap.SaveToStream(Stream); |
| // Calculate size of DIB block. |
| DIBSize := Stream.Size - SizeOf(TBitmapFileHeader); |
| // Allocate memory for DIB data. |
| Result := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE, DIBSize); |
| if (Result = 0) then |
| exit; |
| DIB := GlobalLock(Result); |
| if DIB = nil then |
| begin |
| GlobalFree(Result); |
| Result := 0; |
| end else |
| begin |
| // Skip BMP file header. |
| Stream.Seek(SizeOf(TBitmapFileHeader), soFromBeginning); |
| // Transfer data from stream to global memory. |
| if (Stream.Read(DIB^, DIBSize) <> DIBSize) then |
| begin |
| GlobalUnlock(Result); |
| GlobalFree(Result); |
| Result := 0; |
| end else |
| GlobalUnlock(Result); |
| end; |
| finally |
| Stream.free; |
| end; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TGDIClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TGDIClipboardFormat.Create; |
| begin |
| CreateFormat(TYMED_GDI); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TPaletteClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TPaletteClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| Result := CF_PALETTE; |
| end; |
| procedure TPaletteClipboardFormat.Clear; |
| begin |
| if (FPalette <> 0) then |
| begin |
| DeleteObject(FPalette); |
| FPalette := 0; |
| end; |
| end; |
| function TPaletteClipboardFormat.DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean; |
| begin |
| if (AMedium.hBitmap <> 0) then |
| begin |
| FPalette := CopyPalette(AMedium.hBitmap); |
| Result := (FPalette <> 0); |
| end else |
| Result := False; |
| end; |
| function TPaletteClipboardFormat.DoSetData(const FormatEtcIn: TFormatEtc; |
| var Medium: TStgMedium): boolean; |
| begin |
| Result := False; |
| try |
| Medium.hBitmap := CopyPalette(FPalette); |
| except |
| exit; |
| end; |
| if (Medium.hBitmap <> 0) then |
| begin |
| Medium.tymed := TYMED_GDI; |
| result := True; |
| end; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TBitmapClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TCustomBitmapClipboardFormat.CreateFormat(Atymed: Longint); |
| begin |
| inherited CreateFormat(Atymed); |
| FBitmap := Graphics.TBitmap.Create; |
| end; |
| destructor TCustomBitmapClipboardFormat.Destroy; |
| begin |
| if (FBitmap <> nil) then |
| FBitmap.Free; |
| inherited Destroy; |
| end; |
| procedure TCustomBitmapClipboardFormat.Clear; |
| begin |
| FBitmap.Handle := 0; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TBitmapClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TBitmapClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| Result := CF_BITMAP; |
| end; |
| function TBitmapClipboardFormat.DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean; |
| var |
| Palette : TPaletteClipboardFormat; |
| begin |
| Result := False; |
| if (AMedium.hBitmap = 0) then |
| exit; |
| Palette := TPaletteClipboardFormat.Create; |
| try |
| // Attempt to get palette from source. However in case the bitmap is in a |
| // format which doesn't use palettes, there might not be one available. |
| // The CF_BITMAP/CF_PALETTE documentation doesn't mention if CF_BITMAP must |
| // always be accompanied with a CF_PALETTE. |
| Palette.GetData(ADataObject); |
| // Let TBitmap do the work for us. |
| FBitmap.LoadFromClipboardFormat(CF_BITMAP, AMedium.hBitmap, Palette.Palette); |
| finally |
| Palette.Free; |
| end; |
| Result := True; |
| end; |
| function TBitmapClipboardFormat.DoSetData(const FormatEtcIn: TFormatEtc; |
| var AMedium: TStgMedium): boolean; |
| var |
| Palette : HPalette; |
| Format : Word; |
| hBitmap : THandle; |
| begin |
| Result := False; |
| try |
| Format := CF_BITMAP; |
| FBitmap.SaveToClipboardFormat(Format, hBitmap, Palette); |
| AMedium.hBitmap := hBitmap; |
| except |
| exit; |
| end; |
| try |
| if (Format <> CF_BITMAP) then |
| begin |
| DeleteObject(AMedium.hBitmap); |
| AMedium.hBitmap := 0; |
| exit; |
| end; |
| AMedium.tymed := TYMED_GDI; |
| finally |
| DeleteObject(Palette); |
| end; |
| Result := True; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDIBClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDIBClipboardFormat.Create; |
| begin |
| // Note: We must override Create since base class Create sets tymed to |
| // TYMED_GDI. |
| CreateFormat(TYMED_HGLOBAL); |
| end; |
| function TDIBClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| Result := CF_DIB; |
| end; |
| // http://x5.dejanews.com/[ST_rn=ps]/getdoc.xp?AN=382056726.2&CONTEXT=925473183.2090336317&hitnum=0 |
| function TDIBClipboardFormat.DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean; |
| var |
| BitmapInfo : PBitmapInfo; |
| BitmapFileHeader : TBitmapFileHeader; |
| DIBSize : integer; |
| FileSize : integer; |
| InfoSize : integer; |
| Stream : TMemoryStream; |
| begin |
| // Get data source's DIB block |
| BitmapInfo := GlobalLock(AMedium.HGlobal); |
| try |
| Result := (BitmapInfo <> nil); |
| if (not Result) then |
| exit; |
| // Write DIB to a stream in the BMP file format |
| Stream := TMemoryStream.Create; |
| try |
| // Get size of data source's DIB block |
| DIBSize := GlobalSize(AMedium.HGlobal); |
| // Calculate total bitmap file size |
| FileSize := sizeof(TBitmapFileHeader) + DIBSize; |
| // Calculate bitmap header size |
| InfoSize := sizeof(TBitmapInfoHeader); |
| if (BitmapInfo^.bmiHeader.biBitCount > 8) then |
| begin |
| if ((BitmapInfo^.bmiHeader.biCompression and BI_BITFIELDS) <> 0) then |
| Inc(InfoSize, 12); |
| end else |
| Inc(InfoSize, sizeof(TRGBQuad) * (1 shl BitmapInfo^.bmiHeader.biBitCount)); |
| Stream.SetSize(FileSize); |
| // Initialize file header |
| FillChar(BitmapFileHeader, sizeof(TBitmapFileHeader), 0); |
| with BitmapFileHeader do |
| begin |
| bfType := $4D42; // 'BM' = Windows BMP signature |
| bfSize := FileSize; // File size (not needed) |
| bfOffBits := sizeof(TBitmapFileHeader) + InfoSize; // Offset of pixel data |
| end; |
| // Save file header |
| Stream.Write(BitmapFileHeader, sizeof(TBitmapFileHeader)); |
| // Save TBitmapInfo structure and pixel data |
| Stream.Write(BitmapInfo^, DIBSize); |
| // Rewind and load bitmap from stream |
| Stream.Position := 0; |
| FBitmap.LoadFromStream(Stream); |
| finally |
| Stream.Free; |
| end; |
| finally |
| GlobalUnlock(AMedium.HGlobal); |
| end; |
| end; |
| function TDIBClipboardFormat.DoSetData(const FormatEtcIn: TFormatEtc; |
| var AMedium: TStgMedium): boolean; |
| begin |
| AMedium.hBitmap := GetHGlobalDIBFromBitmap(FBitmap); |
| Result := (AMedium.hBitmap <> 0); |
| if (Result) then |
| AMedium.tymed := TYMED_HGLOBAL; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomMetaFileClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TCustomMetaFileClipboardFormat.Create; |
| begin |
| CreateFormat(TYMED_MFPICT); |
| FMetaFile := TMetaFile.Create; |
| end; |
| destructor TCustomMetaFileClipboardFormat.Destroy; |
| begin |
| if (FMetaFile <> nil) then |
| FMetaFile.Free; |
| inherited Destroy; |
| end; |
| procedure TCustomMetaFileClipboardFormat.Clear; |
| begin |
| FMetaFile.Clear; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TMetaFileClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TMetaFileClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| Result := CF_METAFILEPICT; |
| end; |
| function WMF2EMF(const MetaFile: TMetaFilePict): hEnhMetaFile; |
| var |
| Bits : Pointer; |
| Length : UINT; |
| RefDC : HDC; |
| begin |
| Length := GetMetaFileBitsEx(MetaFile.hMF, 0, nil); |
| if (Length = 0) then |
| _RaiseLastWin32Error; |
| GetMem(Bits, Length); |
| try |
| if (GetMetaFileBitsEx(MetaFile.hMF, Length, Bits) < Length) then |
| _RaiseLastWin32Error; |
| RefDC := GetDC(0); |
| try |
| Result := SetWinMetaFileBits(Length, Bits, RefDC, MetaFile); |
| finally |
| ReleaseDC(0, RefDC); |
| end; |
| if (Result = 0) then |
| _RaiseLastWin32Error; |
| finally |
| FreeMem(Bits); |
| end; |
| end; |
| function TMetaFileClipboardFormat.DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean; |
| var |
| pMetaFile : PMetaFilePict; |
| begin |
| pMetaFile := GlobalLock(AMedium.hMetaFilePict); |
| try |
| Result := (pMetaFile <> nil); |
| if (Result) then |
| FMetaFile.Handle := WMF2EMF(pMetaFile^); |
| finally |
| GlobalUnlock(AMedium.hMetaFilePict); |
| end; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TEnhMetaFileClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TEnhMetaFileClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| Result := CF_ENHMETAFILE; |
| end; |
| function TEnhMetaFileClipboardFormat.DoGetData(ADataObject: IDataObject; const AMedium: TStgMedium): boolean; |
| begin |
| Result := (AMedium.hEnhMetaFile <> 0); |
| if (Result) then |
| FMetaFile.Handle := CopyEnhMetafile(AMedium.hEnhMetaFile, nil); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TBitmapDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TBitmapDataFormat.Create(AOwner: TDragDropComponent); |
| begin |
| inherited Create(AOwner); |
| FBitmap := TBitmap.Create; |
| // TGraphic.OnChange is fired too late (after change), but it's the best |
| // we can get. |
| FBitmap.OnChange := DoOnChanging; |
| end; |
| destructor TBitmapDataFormat.Destroy; |
| begin |
| Clear; |
| FBitmap.Free; |
| inherited Destroy; |
| end; |
| function TBitmapDataFormat.Assign(Source: TClipboardFormat): boolean; |
| begin |
| Result := True; |
| if (Source is TDIBClipboardFormat) then |
| FBitmap.Assign(TDIBClipboardFormat(Source).Bitmap) |
| else if (Source is TBitmapClipboardFormat) then |
| FBitmap.Assign(TBitmapClipboardFormat(Source).Bitmap) |
| // TODO -oanme : Is this nescessary? Palette is extracted in TBitmapClipboardFormat GetData. |
| else if (Source is TPaletteClipboardFormat) then |
| FBitmap.Palette := CopyPalette(TPaletteClipboardFormat(Source).Palette) |
| else |
| Result := inherited Assign(Source); |
| end; |
| function TBitmapDataFormat.AssignTo(Dest: TClipboardFormat): boolean; |
| begin |
| Result := True; |
| if (Dest is TDIBClipboardFormat) then |
| TDIBClipboardFormat(Dest).Bitmap.Assign(FBitmap) |
| else if (Dest is TBitmapClipboardFormat) then |
| TBitmapClipboardFormat(Dest).Bitmap.Assign(FBitmap) |
| else if (Dest is TPaletteClipboardFormat) then |
| TPaletteClipboardFormat(Dest).Palette := CopyPalette(FBitmap.Palette) |
| else |
| Result := inherited AssignTo(Dest); |
| end; |
| procedure TBitmapDataFormat.Clear; |
| begin |
| Changing; |
| FBitmap.Handle := 0; |
| end; |
| function TBitmapDataFormat.HasData: boolean; |
| begin |
| Result := (not FBitmap.Empty); |
| end; |
| function TBitmapDataFormat.NeedsData: boolean; |
| begin |
| Result := (FBitmap.Empty); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TMetaFileDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TMetaFileDataFormat.Create(AOwner: TDragDropComponent); |
| begin |
| inherited Create(AOwner); |
| FMetaFile := TMetaFile.Create; |
| // TGraphic.OnChange is fired too late (after change), but it's the best |
| // we can get. |
| FMetaFile.OnChange := DoOnChanging; |
| end; |
| destructor TMetaFileDataFormat.Destroy; |
| begin |
| Clear; |
| FMetaFile.Free; |
| inherited Destroy; |
| end; |
| function TMetaFileDataFormat.Assign(Source: TClipboardFormat): boolean; |
| begin |
| Result := True; |
| if (Source is TMetaFileClipboardFormat) then |
| FMetaFile.Assign(TMetaFileClipboardFormat(Source).MetaFile) |
| else if (Source is TEnhMetaFileClipboardFormat) then |
| FMetaFile.Assign(TEnhMetaFileClipboardFormat(Source).MetaFile) |
| else |
| Result := inherited Assign(Source); |
| end; |
| procedure TMetaFileDataFormat.Clear; |
| begin |
| Changing; |
| FMetaFile.Clear; |
| end; |
| function TMetaFileDataFormat.HasData: boolean; |
| begin |
| Result := (FMetaFile.Handle <> 0); |
| end; |
| function TMetaFileDataFormat.NeedsData: boolean; |
| begin |
| Result := (FMetaFile.Handle = 0); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropBMPTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDropBMPTarget.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| FBitmapFormat := TBitmapDataFormat.Create(Self); |
| end; |
| destructor TDropBMPTarget.Destroy; |
| begin |
| FBitmapFormat.Free; |
| inherited Destroy; |
| end; |
| function TDropBMPTarget.GetBitmap: TBitmap; |
| begin |
| Result := FBitmapFormat.Bitmap; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropBMPSource |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDropBMPSource.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| DragTypes := [dtCopy]; // Default to Copy |
| FBitmapFormat := TBitmapDataFormat.Create(Self); |
| end; |
| destructor TDropBMPSource.destroy; |
| begin |
| FBitmapFormat.Free; |
| inherited Destroy; |
| end; |
| function TDropBMPSource.GetBitmap: TBitmap; |
| begin |
| Result := FBitmapFormat.Bitmap; |
| end; |
| procedure TDropBMPSource.SetBitmap(const Value: TBitmap); |
| begin |
| FBitmapFormat.Bitmap.Assign(Value); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropMetaFileTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDropMetaFileTarget.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| FMetaFileFormat := TMetaFileDataFormat.Create(Self); |
| end; |
| destructor TDropMetaFileTarget.Destroy; |
| begin |
| FMetaFileFormat.Free; |
| inherited Destroy; |
| end; |
| function TDropMetaFileTarget.GetMetaFile: TMetaFile; |
| begin |
| Result := FMetaFileFormat.MetaFile; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropMetaFileTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDropImageTarget.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| FMetaFileFormat := TMetaFileDataFormat.Create(Self); |
| FBitmapFormat := TBitmapDataFormat.Create(Self); |
| FPicture := TPicture.Create; |
| end; |
| destructor TDropImageTarget.Destroy; |
| begin |
| FPicture.Free; |
| FBitmapFormat.Free; |
| FMetaFileFormat.Free; |
| inherited Destroy; |
| end; |
| procedure TDropImageTarget.ClearData; |
| begin |
| inherited ClearData; |
| FPicture.Assign(nil); |
| end; |
| function TDropImageTarget.DoGetData: boolean; |
| begin |
| Result := inherited DoGetData; |
| if (Result) then |
| begin |
| if (FBitmapFormat.HasData) then |
| FPicture.Assign(FBitmapFormat.Bitmap) |
| else if (FMetaFileFormat.HasData) then |
| FPicture.Assign(FMetaFileFormat.MetaFile) |
| else |
| Result := False; |
| end; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Initialization/Finalization |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| initialization |
| // Data format registration |
| TBitmapDataFormat.RegisterDataFormat; |
| TMetaFileDataFormat.RegisterDataFormat; |
| // Clipboard format registration |
| TBitmapDataFormat.RegisterCompatibleFormat(TDIBClipboardFormat, 0, csSourceTarget, [ddRead]); |
| TBitmapDataFormat.RegisterCompatibleFormat(TBitmapClipboardFormat, 1, csSourceTarget, [ddRead]); |
| TBitmapDataFormat.RegisterCompatibleFormat(TPaletteClipboardFormat, 1, csSourceTarget, [ddRead]); |
| TMetaFileDataFormat.RegisterCompatibleFormat(TEnhMetaFileClipboardFormat, 0, [csTarget], [ddRead]); |
| TMetaFileDataFormat.RegisterCompatibleFormat(TMetaFileClipboardFormat, 1, [csTarget], [ddRead]); |
| finalization |
| // It is not nescessary to unregister *both* the TClipboardFormats and |
| // the TTargetFormat, but we do it here to demo how the unregister |
| // methods are used. |
| // Clipboard format unregistration |
| TDIBClipboardFormat.UnregisterClipboardFormat; |
| TBitmapClipboardFormat.UnregisterClipboardFormat; |
| TPaletteClipboardFormat.UnregisterClipboardFormat; |
| TEnhMetaFileClipboardFormat.UnregisterClipboardFormat; |
| TMetaFileClipboardFormat.UnregisterClipboardFormat; |
| // Target format unregistration |
| TBitmapDataFormat.UnregisterDataFormat; |
| TMetaFileDataFormat.UnregisterDataFormat; |
| end. |
| /trunk/VCL_DRAGDROP/DragDropHandler.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DragDropHandler.pas |
|---|
| 0,0 → 1,208 |
| unit DragDropHandler; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite. |
| // Module: DragDropHandler |
| // Description: Implements Drop and Drop Context Menu Shell Extenxions |
| // (a.k.a. drag-and-drop handlers). |
| // Version: 4.0 |
| // Date: 18-MAY-2001 |
| // Target: Win32, Delphi 5-6 |
| // Authors: Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2001 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DragDrop, |
| DragDropComObj, |
| DragDropContext, |
| Menus, |
| ShlObj, |
| ActiveX, |
| Windows, |
| Classes; |
| {$include DragDrop.inc} |
| type |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDragDropHandler |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // A typical drag-and-drop handler session goes like this: |
| // 1. User right-drags (drags with the right mouse button) and drops one or more |
| // source files which has a registered drag-and-drop handler. |
| // 2. The shell loads the drag-and-drop handler module. |
| // 3. The shell instantiates the registered drag drop handler object as an |
| // in-process COM server. |
| // 4. The IShellExtInit.Initialize method is called with the name of the target |
| // folder and a data object which contains the dragged data. |
| // The target folder name is stored in the TDragDropHandler.TargetFolder |
| // property as a string and in the TargetPIDL property as a PIDL. |
| // 5. The IContextMenu.QueryContextMenu method is called to populate the popup |
| // menu. |
| // TDragDropHandler uses the PopupMenu property to populate the drag-and-drop |
| // context menu. |
| // 6. If the user chooses one of the context menu items we have supplied, the |
| // IContextMenu.InvokeCommand method is called. |
| // TDragDropHandler locates the corresponding TMenuItem and fires the menu |
| // items OnClick event. |
| // 7. The shell unloads the drag-and-drop handler module (usually after a few |
| // seconds). |
| //////////////////////////////////////////////////////////////////////////////// |
| TDragDropHandler = class(TDropContextMenu, IShellExtInit, IContextMenu) |
| private |
| FFolderPIDL: pItemIDList; |
| protected |
| function GetFolder: string; |
| { IShellExtInit } |
| function Initialize(pidlFolder: PItemIDList; lpdobj: IDataObject; |
| hKeyProgID: HKEY): HResult; stdcall; |
| { IContextMenu } |
| function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast, |
| uFlags: UINT): HResult; stdcall; |
| function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall; |
| function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; |
| pszName: LPSTR; cchMax: UINT): HResult; stdcall; |
| public |
| destructor Destroy; override; |
| function GetFolderPIDL: pItemIDList; // Caller must free PIDL! |
| property Folder: string read GetFolder; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDragDropHandlerFactory |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // COM Class factory for TDragDropHandler. |
| //////////////////////////////////////////////////////////////////////////////// |
| TDragDropHandlerFactory = class(TDropContextMenuFactory) |
| protected |
| function HandlerRegSubKey: string; override; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Misc. |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // IMPLEMENTATION |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| implementation |
| uses |
| DragDropFile, |
| DragDropPIDL, |
| Registry, |
| ComObj, |
| SysUtils; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| begin |
| RegisterComponents(DragDropComponentPalettePage, [TDragDropHandler]); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Utilities |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDragDropHandler |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| destructor TDragDropHandler.Destroy; |
| begin |
| if (FFolderPIDL <> nil) then |
| ShellMalloc.Free(FFolderPIDL); |
| inherited Destroy; |
| end; |
| function TDragDropHandler.GetCommandString(idCmd, uType: UINT; |
| pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult; |
| begin |
| Result := inherited GetCommandString(idCmd, uType, pwReserved, pszName, cchMax); |
| end; |
| function TDragDropHandler.GetFolder: string; |
| begin |
| Result := GetFullPathFromPIDL(FFolderPIDL); |
| end; |
| function TDragDropHandler.GetFolderPIDL: pItemIDList; |
| begin |
| Result := CopyPIDL(FFolderPIDL); |
| end; |
| function TDragDropHandler.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; |
| begin |
| Result := E_FAIL; |
| try |
| Result := inherited InvokeCommand(lpici); |
| finally |
| if (Result <> E_FAIL) then |
| begin |
| ShellMalloc.Free(FFolderPIDL); |
| FFolderPIDL := nil; |
| end; |
| end; |
| end; |
| function TDragDropHandler.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, |
| idCmdLast, uFlags: UINT): HResult; |
| begin |
| Result := inherited QueryContextMenu(Menu, indexMenu, idCmdFirst, |
| idCmdLast, uFlags); |
| end; |
| function TDragDropHandler.Initialize(pidlFolder: PItemIDList; |
| lpdobj: IDataObject; hKeyProgID: HKEY): HResult; |
| begin |
| if (pidlFolder <> nil) then |
| begin |
| // Copy target folder PIDL. |
| FFolderPIDL := CopyPIDL(pidlFolder); |
| Result := inherited Initialize(pidlFolder, lpdobj, hKeyProgID); |
| end else |
| Result := E_INVALIDARG; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDragDropHandlerFactory |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TDragDropHandlerFactory.HandlerRegSubKey: string; |
| begin |
| Result := 'DragDropHandlers'; |
| end; |
| end. |
| /trunk/VCL_DRAGDROP/DragDropInternet.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DragDropInternet.pas |
|---|
| 0,0 → 1,1269 |
| unit DragDropInternet; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite. |
| // Module: DragDropInternet |
| // Description: Implements Dragging and Dropping of internet related data. |
| // Version: 4.0 |
| // Date: 18-MAY-2001 |
| // Target: Win32, Delphi 5-6 |
| // Authors: Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2001 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DragDrop, |
| DropTarget, |
| DropSource, |
| DragDropFormats, |
| Windows, |
| Classes, |
| ActiveX; |
| type |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TURLClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Implements support for the 'UniformResourceLocator' format. |
| //////////////////////////////////////////////////////////////////////////////// |
| TURLClipboardFormat = class(TCustomTextClipboardFormat) |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| property URL: string read GetString write SetString; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TNetscapeBookmarkClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Implements support for the 'Netscape Bookmark' format. |
| //////////////////////////////////////////////////////////////////////////////// |
| TNetscapeBookmarkClipboardFormat = class(TCustomSimpleClipboardFormat) |
| private |
| FURL : string; |
| FTitle : string; |
| protected |
| function ReadData(Value: pointer; Size: integer): boolean; override; |
| function WriteData(Value: pointer; Size: integer): boolean; override; |
| function GetSize: integer; override; |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| procedure Clear; override; |
| property URL: string read FURL write FURL; |
| property Title: string read FTitle write FTitle; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TNetscapeImageClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Implements support for the 'Netscape Image Format' format. |
| //////////////////////////////////////////////////////////////////////////////// |
| TNetscapeImageClipboardFormat = class(TCustomSimpleClipboardFormat) |
| private |
| FURL : string; |
| FTitle : string; |
| FImage : string; |
| FLowRes : string; |
| FExtra : string; |
| FHeight : integer; |
| FWidth : integer; |
| protected |
| function ReadData(Value: pointer; Size: integer): boolean; override; |
| function WriteData(Value: pointer; Size: integer): boolean; override; |
| function GetSize: integer; override; |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| procedure Clear; override; |
| property URL: string read FURL write FURL; |
| property Title: string read FTitle write FTitle; |
| property Image: string read FImage write FImage; |
| property LowRes: string read FLowRes write FLowRes; |
| property Extra: string read FExtra write FExtra; |
| property Height: integer read FHeight write FHeight; |
| property Width: integer read FWidth write FWidth; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TVCardClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Implements support for the '+//ISBN 1-887687-00-9::versit::PDI//vCard' |
| // (vCard) format. |
| //////////////////////////////////////////////////////////////////////////////// |
| TVCardClipboardFormat = class(TCustomStringListClipboardFormat) |
| protected |
| function ReadData(Value: pointer; Size: integer): boolean; override; |
| function WriteData(Value: pointer; Size: integer): boolean; override; |
| function GetSize: integer; override; |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| property Items: TStrings read GetLines; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // THTMLClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Implements support for the 'HTML Format' format. |
| //////////////////////////////////////////////////////////////////////////////// |
| THTMLClipboardFormat = class(TCustomStringListClipboardFormat) |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| function HasData: boolean; override; |
| function Assign(Source: TCustomDataFormat): boolean; override; |
| function AssignTo(Dest: TCustomDataFormat): boolean; override; |
| property HTML: TStrings read GetLines; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TRFC822ClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TRFC822ClipboardFormat = class(TCustomStringListClipboardFormat) |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| function Assign(Source: TCustomDataFormat): boolean; override; |
| function AssignTo(Dest: TCustomDataFormat): boolean; override; |
| property Text: TStrings read GetLines; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TURLDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Renderer for URL formats. |
| //////////////////////////////////////////////////////////////////////////////// |
| TURLDataFormat = class(TCustomDataFormat) |
| private |
| FURL : string; |
| FTitle : string; |
| procedure SetTitle(const Value: string); |
| procedure SetURL(const Value: string); |
| protected |
| public |
| function Assign(Source: TClipboardFormat): boolean; override; |
| function AssignTo(Dest: TClipboardFormat): boolean; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function NeedsData: boolean; override; |
| property URL: string read FURL write SetURL; |
| property Title: string read FTitle write SetTitle; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // THTMLDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Renderer for HTML text data. |
| //////////////////////////////////////////////////////////////////////////////// |
| THTMLDataFormat = class(TCustomDataFormat) |
| private |
| FHTML: TStrings; |
| procedure SetHTML(const Value: TStrings); |
| protected |
| public |
| constructor Create(AOwner: TDragDropComponent); override; |
| destructor Destroy; override; |
| function Assign(Source: TClipboardFormat): boolean; override; |
| function AssignTo(Dest: TClipboardFormat): boolean; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function NeedsData: boolean; override; |
| property HTML: TStrings read FHTML write SetHTML; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TOutlookMailDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Renderer for Microsoft Outlook email formats. |
| //////////////////////////////////////////////////////////////////////////////// |
| (* |
| TOutlookMessage = class; |
| TOutlookAttachments = class(TObject) |
| public |
| property Attachments[Index: integer]: TOutlookMessage; default; |
| property Count: integer; |
| end; |
| TOutlookMessage = class(TObject) |
| public |
| property Text: string; |
| property Stream: IStream; |
| property Attachments: TOutlookAttachments; |
| end; |
| *) |
| TOutlookMailDataFormat = class(TCustomDataFormat) |
| private |
| FStorages : TStorageInterfaceList; |
| protected |
| public |
| constructor Create(AOwner: TDragDropComponent); override; |
| destructor Destroy; override; |
| function Assign(Source: TClipboardFormat): boolean; override; |
| function AssignTo(Dest: TClipboardFormat): boolean; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function NeedsData: boolean; override; |
| property Storages: TStorageInterfaceList read FStorages; |
| // property Streams: TStreamInterfaceList; |
| // property Messages: TOutlookAttachments; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropURLTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // URL drop target component. |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropURLTarget = class(TCustomDropMultiTarget) |
| private |
| FURLFormat : TURLDataFormat; |
| protected |
| function GetTitle: string; |
| function GetURL: string; |
| function GetPreferredDropEffect: LongInt; override; |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; override; |
| property URL: string read GetURL; |
| property Title: string read GetTitle; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropURLSource |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // URL drop source component. |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropURLSource = class(TCustomDropMultiSource) |
| private |
| FURLFormat : TURLDataFormat; |
| procedure SetTitle(const Value: string); |
| procedure SetURL(const Value: string); |
| protected |
| function GetTitle: string; |
| function GetURL: string; |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; override; |
| published |
| property URL: string read GetURL write SetURL; |
| property Title: string read GetTitle write SetTitle; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Misc. |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function GetURLFromFile(const Filename: string; var URL: string): boolean; |
| function GetURLFromStream(Stream: TStream; var URL: string): boolean; |
| function ConvertURLToFilename(const url: string): string; |
| function IsHTML(const s: string): boolean; |
| function MakeHTML(const s: string): string; |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // IMPLEMENTATION |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| implementation |
| uses |
| SysUtils, |
| ShlObj, |
| DragDropFile, |
| DragDropPIDL; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| begin |
| RegisterComponents(DragDropComponentPalettePage, [TDropURLTarget, |
| TDropURLSource]); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Utilities |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function GetURLFromFile(const Filename: string; var URL: string): boolean; |
| var |
| Stream : TStream; |
| begin |
| Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyWrite); |
| try |
| Result := GetURLFromStream(Stream, URL); |
| finally |
| Stream.Free; |
| end; |
| end; |
| function GetURLFromString(const s: string; var URL: string): boolean; |
| var |
| Stream : TMemoryStream; |
| begin |
| Stream := TMemoryStream.Create; |
| try |
| Stream.Size := Length(s); |
| Move(PChar(s)^, Stream.Memory^, Length(s)); |
| Result := GetURLFromStream(Stream, URL); |
| finally |
| Stream.Free; |
| end; |
| end; |
| const |
| // *** DO NOT LOCALIZE *** |
| InternetShortcut = '[InternetShortcut]'; |
| InternetShortcutExt = '.url'; |
| function GetURLFromStream(Stream: TStream; var URL: string): boolean; |
| var |
| URLfile : TStringList; |
| i : integer; |
| s : string; |
| p : PChar; |
| begin |
| Result := False; |
| URLfile := TStringList.Create; |
| try |
| URLFile.LoadFromStream(Stream); |
| i := 0; |
| while (i < URLFile.Count-1) do |
| begin |
| if (CompareText(URLFile[i], InternetShortcut) = 0) then |
| begin |
| inc(i); |
| while (i < URLFile.Count) do |
| begin |
| s := URLFile[i]; |
| p := PChar(s); |
| if (StrLIComp(p, 'URL=', length('URL=')) = 0) then |
| begin |
| inc(p, length('URL=')); |
| URL := p; |
| Result := True; |
| exit; |
| end else |
| if (p^ = '[') then |
| exit; |
| inc(i); |
| end; |
| end; |
| inc(i); |
| end; |
| finally |
| URLFile.Free; |
| end; |
| end; |
| function ConvertURLToFilename(const url: string): string; |
| const |
| Invalids : set of char |
| = ['\', '/', ':', '?', '*', '<', '>', ',', '|', '''', '"']; |
| var |
| i: integer; |
| LastInvalid: boolean; |
| begin |
| Result := url; |
| if (AnsiStrLIComp(PChar(lowercase(Result)), 'http://', 7) = 0) then |
| delete(Result, 1, 7) |
| else if (AnsiStrLIComp(PChar(lowercase(Result)), 'ftp://', 6) = 0) then |
| delete(Result, 1, 6) |
| else if (AnsiStrLIComp(PChar(lowercase(Result)), 'mailto:', 7) = 0) then |
| delete(Result, 1, 7) |
| else if (AnsiStrLIComp(PChar(lowercase(Result)), 'file:', 5) = 0) then |
| delete(Result, 1, 5); |
| if (length(Result) > 120) then |
| SetLength(Result, 120); |
| // Truncate at first slash |
| i := pos('/', Result); |
| if (i > 0) then |
| SetLength(Result, i-1); |
| // Replace invalids with spaces. |
| // If string starts with invalids, they are trimmed. |
| LastInvalid := True; |
| for i := length(Result) downto 1 do |
| if (Result[i] in Invalids) then |
| begin |
| if (not LastInvalid) then |
| begin |
| Result[i] := ' '; |
| LastInvalid := True; |
| end else |
| // Repeating invalids are trimmed. |
| Delete(Result, i, 1); |
| end else |
| LastInvalid := False; |
| if Result = '' then |
| Result := 'untitled'; |
| Result := Result+InternetShortcutExt; |
| end; |
| function IsHTML(const s: string): boolean; |
| begin |
| Result := (pos('<HTML>', Uppercase(s)) > 0); |
| end; |
| function MakeHTML(const s: string): string; |
| begin |
| { TODO -oanme -cImprovement : Needs to escape special chars in text to HTML conversion. } |
| { TODO -oanme -cImprovement : Needs better text to HTML conversion. } |
| if (not IsHTML(s)) then |
| Result := '<HTML>'#13#10'<BODY>'#13#10 + s + #13#10'</BODY>'#13#10'</HTML>' |
| else |
| Result := s; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TURLClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_URL: TClipFormat = 0; |
| function TURLClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_URL = 0) then |
| CF_URL := RegisterClipboardFormat(CFSTR_SHELLURL); |
| Result := CF_URL; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TNetscapeBookmarkClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_NETSCAPEBOOKMARK: TClipFormat = 0; |
| function TNetscapeBookmarkClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_NETSCAPEBOOKMARK = 0) then |
| CF_NETSCAPEBOOKMARK := RegisterClipboardFormat('Netscape Bookmark'); // *** DO NOT LOCALIZE *** |
| Result := CF_NETSCAPEBOOKMARK; |
| end; |
| function TNetscapeBookmarkClipboardFormat.GetSize: integer; |
| begin |
| Result := 0; |
| if (FURL <> '') then |
| begin |
| inc(Result, 1024); |
| if (FTitle <> '') then |
| inc(Result, 1024); |
| end; |
| end; |
| function TNetscapeBookmarkClipboardFormat.ReadData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| // Note: No check for missing string terminator! |
| FURL := PChar(Value); |
| if (Size > 1024) then |
| begin |
| inc(PChar(Value), 1024); |
| FTitle := PChar(Value); |
| end; |
| Result := True; |
| end; |
| function TNetscapeBookmarkClipboardFormat.WriteData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| StrLCopy(Value, PChar(FURL), Size); |
| dec(Size, 1024); |
| if (Size > 0) and (FTitle <> '') then |
| begin |
| inc(PChar(Value), 1024); |
| StrLCopy(Value, PChar(FTitle), Size); |
| end; |
| Result := True; |
| end; |
| procedure TNetscapeBookmarkClipboardFormat.Clear; |
| begin |
| FURL := ''; |
| FTitle := ''; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TNetscapeImageClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_NETSCAPEIMAGE: TClipFormat = 0; |
| function TNetscapeImageClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_NETSCAPEIMAGE = 0) then |
| CF_NETSCAPEIMAGE := RegisterClipboardFormat('Netscape Image Format'); |
| Result := CF_NETSCAPEIMAGE; |
| end; |
| type |
| TNetscapeImageRec = record |
| Size , |
| _Unknown1 , |
| Width , |
| Height , |
| HorMargin , |
| VerMargin , |
| Border , |
| OfsLowRes , |
| OfsTitle , |
| OfsURL , |
| OfsExtra : DWORD |
| end; |
| PNetscapeImageRec = ^TNetscapeImageRec; |
| function TNetscapeImageClipboardFormat.GetSize: integer; |
| begin |
| Result := SizeOf(TNetscapeImageRec); |
| inc(Result, Length(FImage)+1); |
| if (FLowRes <> '') then |
| inc(Result, Length(FLowRes)+1); |
| if (FTitle <> '') then |
| inc(Result, Length(FTitle)+1); |
| if (FUrl <> '') then |
| inc(Result, Length(FUrl)+1); |
| if (FExtra <> '') then |
| inc(Result, Length(FExtra)+1); |
| end; |
| function TNetscapeImageClipboardFormat.ReadData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| Result := (Size > SizeOf(TNetscapeImageRec)); |
| if (Result) then |
| begin |
| FWidth := PNetscapeImageRec(Value)^.Width; |
| FHeight := PNetscapeImageRec(Value)^.Height; |
| FImage := PChar(Value) + SizeOf(TNetscapeImageRec); |
| if (PNetscapeImageRec(Value)^.OfsLowRes <> 0) then |
| FLowRes := PChar(Value) + PNetscapeImageRec(Value)^.OfsLowRes; |
| if (PNetscapeImageRec(Value)^.OfsTitle <> 0) then |
| FTitle := PChar(Value) + PNetscapeImageRec(Value)^.OfsTitle; |
| if (PNetscapeImageRec(Value)^.OfsURL <> 0) then |
| FUrl := PChar(Value) + PNetscapeImageRec(Value)^.OfsUrl; |
| if (PNetscapeImageRec(Value)^.OfsExtra <> 0) then |
| FExtra := PChar(Value) + PNetscapeImageRec(Value)^.OfsExtra; |
| end; |
| end; |
| function TNetscapeImageClipboardFormat.WriteData(Value: pointer; |
| Size: integer): boolean; |
| var |
| NetscapeImageRec : PNetscapeImageRec; |
| begin |
| Result := (Size > SizeOf(TNetscapeImageRec)); |
| if (Result) then |
| begin |
| NetscapeImageRec := PNetscapeImageRec(Value); |
| NetscapeImageRec^.Width := FWidth; |
| NetscapeImageRec^.Height := FHeight; |
| inc(PChar(Value), SizeOf(TNetscapeImageRec)); |
| dec(Size, SizeOf(TNetscapeImageRec)); |
| StrLCopy(Value, PChar(FImage), Size); |
| dec(Size, Length(FImage)+1); |
| if (Size <= 0) then |
| exit; |
| if (FLowRes <> '') then |
| begin |
| StrLCopy(Value, PChar(FLowRes), Size); |
| NetscapeImageRec^.OfsLowRes := integer(Value) - integer(NetscapeImageRec); |
| dec(Size, Length(FLowRes)+1); |
| inc(PChar(Value), Length(FLowRes)+1); |
| if (Size <= 0) then |
| exit; |
| end; |
| if (FTitle <> '') then |
| begin |
| StrLCopy(Value, PChar(FTitle), Size); |
| NetscapeImageRec^.OfsTitle := integer(Value) - integer(NetscapeImageRec); |
| dec(Size, Length(FTitle)+1); |
| inc(PChar(Value), Length(FTitle)+1); |
| if (Size <= 0) then |
| exit; |
| end; |
| if (FUrl <> '') then |
| begin |
| StrLCopy(Value, PChar(FUrl), Size); |
| NetscapeImageRec^.OfsUrl := integer(Value) - integer(NetscapeImageRec); |
| dec(Size, Length(FUrl)+1); |
| inc(PChar(Value), Length(FUrl)+1); |
| if (Size <= 0) then |
| exit; |
| end; |
| if (FExtra <> '') then |
| begin |
| StrLCopy(Value, PChar(FExtra), Size); |
| NetscapeImageRec^.OfsExtra := integer(Value) - integer(NetscapeImageRec); |
| dec(Size, Length(FExtra)+1); |
| inc(PChar(Value), Length(FExtra)+1); |
| if (Size <= 0) then |
| exit; |
| end; |
| end; |
| end; |
| procedure TNetscapeImageClipboardFormat.Clear; |
| begin |
| FURL := ''; |
| FTitle := ''; |
| FImage := ''; |
| FLowRes := ''; |
| FExtra := ''; |
| FHeight := 0; |
| FWidth := 0; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TVCardClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_VCARD: TClipFormat = 0; |
| function TVCardClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_VCARD = 0) then |
| CF_VCARD := RegisterClipboardFormat('+//ISBN 1-887687-00-9::versit::PDI//vCard'); // *** DO NOT LOCALIZE *** |
| Result := CF_VCARD; |
| end; |
| function TVCardClipboardFormat.GetSize: integer; |
| var |
| i : integer; |
| begin |
| if (Items.Count > 0) then |
| begin |
| Result := 22; // Length('begin:vcard'+#13+'end:vcard'+#0); |
| for i := 0 to Items.Count-1 do |
| inc(Result, Length(Items[i])+1); |
| end else |
| Result := 0; |
| end; |
| function TVCardClipboardFormat.ReadData(Value: pointer; Size: integer): boolean; |
| var |
| i : integer; |
| s : string; |
| begin |
| Result := inherited ReadData(Value, Size); |
| if (Result) then |
| begin |
| // Zap vCard header and trailer |
| if (Items.Count > 0) and (CompareText(Items[0], 'begin:vcard') = 0) then |
| Items.Delete(0); |
| if (Items.Count > 0) and (CompareText(Items[Items.Count-1], 'end:vcard') = 0) then |
| Items.Delete(Items.Count-1); |
| // Convert to item/value list |
| for i := 0 to Items.Count-1 do |
| if (pos(':', Items[i]) > 0) then |
| begin |
| s := Items[i]; |
| s[pos(':', Items[i])] := '='; |
| Items[i] := s; |
| end; |
| end; |
| end; |
| function DOSStringToUnixString(dos: string): string; |
| var |
| s, d : PChar; |
| l : integer; |
| begin |
| SetLength(Result, Length(dos)+1); |
| s := PChar(dos); |
| d := PChar(Result); |
| l := 1; |
| while (s^ <> #0) do |
| begin |
| // Ignore LF |
| if (s^ <> #10) then |
| begin |
| d^ := s^; |
| inc(l); |
| inc(d); |
| end; |
| inc(s); |
| end; |
| SetLength(Result, l); |
| end; |
| function TVCardClipboardFormat.WriteData(Value: pointer; Size: integer): boolean; |
| var |
| s : string; |
| begin |
| Result := (Items.Count > 0); |
| if (Result) then |
| begin |
| s := DOSStringToUnixString('begin:vcard'+#13+Items.Text+#13+'end:vcard'); |
| StrLCopy(Value, PChar(s), Size); |
| end; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // THTMLClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_HTML: TClipFormat = 0; |
| function THTMLClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_HTML = 0) then |
| CF_HTML := RegisterClipboardFormat('HTML Format'); |
| Result := CF_HTML; |
| end; |
| function THTMLClipboardFormat.HasData: boolean; |
| begin |
| Result := inherited HasData and IsHTML(HTML.Text); |
| end; |
| function THTMLClipboardFormat.Assign(Source: TCustomDataFormat): boolean; |
| begin |
| Result := True; |
| if (Source is TTextDataFormat) then |
| HTML.Text := MakeHTML(TTextDataFormat(Source).Text) |
| else |
| Result := inherited Assign(Source); |
| end; |
| function THTMLClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean; |
| begin |
| Result := True; |
| if (Dest is TTextDataFormat) then |
| TTextDataFormat(Dest).Text := HTML.Text |
| else |
| Result := inherited AssignTo(Dest); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TRFC822ClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_RFC822: TClipFormat = 0; |
| function TRFC822ClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_RFC822 = 0) then |
| CF_RFC822 := RegisterClipboardFormat('Internet Message (rfc822/rfc1522)'); // *** DO NOT LOCALIZE *** |
| Result := CF_RFC822; |
| end; |
| function TRFC822ClipboardFormat.Assign(Source: TCustomDataFormat): boolean; |
| begin |
| Result := True; |
| if (Source is TTextDataFormat) then |
| Text.Text := TTextDataFormat(Source).Text |
| else |
| Result := inherited Assign(Source); |
| end; |
| function TRFC822ClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean; |
| begin |
| Result := True; |
| if (Dest is TTextDataFormat) then |
| TTextDataFormat(Dest).Text := Text.Text |
| else |
| Result := inherited AssignTo(Dest); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TURLDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TURLDataFormat.Assign(Source: TClipboardFormat): boolean; |
| var |
| s : string; |
| begin |
| Result := False; |
| (* |
| ** TURLClipboardFormat |
| *) |
| if (Source is TURLClipboardFormat) then |
| begin |
| if (FURL = '') then |
| FURL := TURLClipboardFormat(Source).URL; |
| Result := True; |
| end else |
| (* |
| ** TTextClipboardFormat |
| *) |
| if (Source is TTextClipboardFormat) then |
| begin |
| if (FURL = '') then |
| begin |
| s := TTextClipboardFormat(Source).Text; |
| // Convert from text if the string looks like an URL |
| if (pos('://', s) > 1) then |
| begin |
| FURL := s; |
| Result := True; |
| end; |
| end; |
| end else |
| (* |
| ** TFileClipboardFormat |
| *) |
| if (Source is TFileClipboardFormat) then |
| begin |
| if (FURL = '') then |
| begin |
| s := TFileClipboardFormat(Source).Files[0]; |
| // Convert from Internet Shortcut file format. |
| if (CompareText(ExtractFileExt(s), InternetShortcutExt) = 0) and |
| (GetURLFromFile(s, FURL)) then |
| begin |
| if (FTitle = '') then |
| FTitle := ChangeFileExt(ExtractFileName(s), ''); |
| Result := True; |
| end; |
| end; |
| end else |
| (* |
| ** TFileContentsClipboardFormat |
| *) |
| if (Source is TFileContentsClipboardFormat) then |
| begin |
| if (FURL = '') then |
| begin |
| s := TFileContentsClipboardFormat(Source).Data; |
| Result := GetURLFromString(s, FURL); |
| end; |
| end else |
| (* |
| ** TFileGroupDescritorClipboardFormat |
| *) |
| if (Source is TFileGroupDescritorClipboardFormat) then |
| begin |
| if (FTitle = '') then |
| begin |
| if (TFileGroupDescritorClipboardFormat(Source).FileGroupDescriptor^.cItems > 0) then |
| begin |
| // Extract the title of an Internet Shortcut |
| s := TFileGroupDescritorClipboardFormat(Source).FileGroupDescriptor^.fgd[0].cFileName; |
| if (CompareText(ExtractFileExt(s), InternetShortcutExt) = 0) then |
| begin |
| FTitle := ChangeFileExt(s, ''); |
| Result := True; |
| end; |
| end; |
| end; |
| end else |
| (* |
| ** TNetscapeBookmarkClipboardFormat |
| *) |
| if (Source is TNetscapeBookmarkClipboardFormat) then |
| begin |
| if (FURL = '') then |
| FURL := TNetscapeBookmarkClipboardFormat(Source).URL; |
| if (FTitle = '') then |
| FTitle := TNetscapeBookmarkClipboardFormat(Source).Title; |
| Result := True; |
| end else |
| (* |
| ** TNetscapeImageClipboardFormat |
| *) |
| if (Source is TNetscapeImageClipboardFormat) then |
| begin |
| if (FURL = '') then |
| FURL := TNetscapeImageClipboardFormat(Source).URL; |
| if (FTitle = '') then |
| FTitle := TNetscapeImageClipboardFormat(Source).Title; |
| Result := True; |
| end else |
| Result := inherited Assign(Source); |
| end; |
| function TURLDataFormat.AssignTo(Dest: TClipboardFormat): boolean; |
| var |
| FGD : TFileGroupDescriptor; |
| s : string; |
| begin |
| Result := True; |
| (* |
| ** TURLClipboardFormat |
| *) |
| if (Dest is TURLClipboardFormat) then |
| begin |
| TURLClipboardFormat(Dest).URL := FURL; |
| end else |
| (* |
| ** TTextClipboardFormat |
| *) |
| if (Dest is TTextClipboardFormat) then |
| begin |
| TTextClipboardFormat(Dest).Text := FURL; |
| end else |
| (* |
| ** TFileContentsClipboardFormat |
| *) |
| if (Dest is TFileContentsClipboardFormat) then |
| begin |
| TFileContentsClipboardFormat(Dest).Data := InternetShortcut + #13#10 + |
| 'URL='+FURL + #13#10; |
| end else |
| (* |
| ** TFileGroupDescritorClipboardFormat |
| *) |
| if (Dest is TFileGroupDescritorClipboardFormat) then |
| begin |
| FillChar(FGD, SizeOf(FGD), 0); |
| FGD.cItems := 1; |
| if (FTitle = '') then |
| s := FURL |
| else |
| s := FTitle; |
| StrLCopy(@FGD.fgd[0].cFileName[0], PChar(ConvertURLToFilename(s)), |
| SizeOf(FGD.fgd[0].cFileName)); |
| FGD.fgd[0].dwFlags := FD_LINKUI; |
| TFileGroupDescritorClipboardFormat(Dest).CopyFrom(@FGD); |
| end else |
| (* |
| ** TNetscapeBookmarkClipboardFormat |
| *) |
| if (Dest is TNetscapeBookmarkClipboardFormat) then |
| begin |
| TNetscapeBookmarkClipboardFormat(Dest).URL := FURL; |
| TNetscapeBookmarkClipboardFormat(Dest).Title := FTitle; |
| end else |
| (* |
| ** TNetscapeImageClipboardFormat |
| *) |
| if (Dest is TNetscapeImageClipboardFormat) then |
| begin |
| TNetscapeImageClipboardFormat(Dest).URL := FURL; |
| TNetscapeImageClipboardFormat(Dest).Title := FTitle; |
| end else |
| Result := inherited AssignTo(Dest); |
| end; |
| procedure TURLDataFormat.Clear; |
| begin |
| Changing; |
| FURL := ''; |
| FTitle := ''; |
| end; |
| procedure TURLDataFormat.SetTitle(const Value: string); |
| begin |
| Changing; |
| FTitle := Value; |
| end; |
| procedure TURLDataFormat.SetURL(const Value: string); |
| begin |
| Changing; |
| FURL := Value; |
| end; |
| function TURLDataFormat.HasData: boolean; |
| begin |
| Result := (FURL <> '') or (FTitle <> ''); |
| end; |
| function TURLDataFormat.NeedsData: boolean; |
| begin |
| Result := (FURL = '') or (FTitle = ''); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // THTMLDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function THTMLDataFormat.Assign(Source: TClipboardFormat): boolean; |
| begin |
| Result := True; |
| if (Source is THTMLClipboardFormat) then |
| FHTML.Assign(THTMLClipboardFormat(Source).HTML) |
| else |
| Result := inherited Assign(Source); |
| end; |
| function THTMLDataFormat.AssignTo(Dest: TClipboardFormat): boolean; |
| begin |
| Result := True; |
| if (Dest is THTMLClipboardFormat) then |
| THTMLClipboardFormat(Dest).HTML.Assign(FHTML) |
| else |
| Result := inherited AssignTo(Dest); |
| end; |
| procedure THTMLDataFormat.Clear; |
| begin |
| Changing; |
| FHTML.Clear; |
| end; |
| constructor THTMLDataFormat.Create(AOwner: TDragDropComponent); |
| begin |
| inherited Create(AOwner); |
| FHTML := TStringList.Create; |
| end; |
| destructor THTMLDataFormat.Destroy; |
| begin |
| FHTML.Free; |
| inherited Destroy; |
| end; |
| function THTMLDataFormat.HasData: boolean; |
| begin |
| Result := (FHTML.Count > 0); |
| end; |
| function THTMLDataFormat.NeedsData: boolean; |
| begin |
| Result := (FHTML.Count = 0); |
| end; |
| procedure THTMLDataFormat.SetHTML(const Value: TStrings); |
| begin |
| FHTML.Assign(Value); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TOutlookMailDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TOutlookMailDataFormat.Create(AOwner: TDragDropComponent); |
| begin |
| inherited Create(AOwner); |
| FStorages := TStorageInterfaceList.Create; |
| FStorages.OnChanging := DoOnChanging; |
| end; |
| destructor TOutlookMailDataFormat.Destroy; |
| begin |
| Clear; |
| FStorages.Free; |
| inherited Destroy; |
| end; |
| procedure TOutlookMailDataFormat.Clear; |
| begin |
| Changing; |
| FStorages.Clear; |
| end; |
| function TOutlookMailDataFormat.Assign(Source: TClipboardFormat): boolean; |
| begin |
| Result := True; |
| if (Source is TFileContentsStorageClipboardFormat) then |
| FStorages.Assign(TFileContentsStorageClipboardFormat(Source).Storages) |
| else |
| Result := inherited Assign(Source); |
| end; |
| function TOutlookMailDataFormat.AssignTo(Dest: TClipboardFormat): boolean; |
| begin |
| Result := True; |
| if (Dest is TFileContentsStorageClipboardFormat) then |
| TFileContentsStorageClipboardFormat(Dest).Storages.Assign(FStorages) |
| else |
| Result := inherited AssignTo(Dest); |
| end; |
| function TOutlookMailDataFormat.HasData: boolean; |
| begin |
| Result := (FStorages.Count > 0); |
| end; |
| function TOutlookMailDataFormat.NeedsData: boolean; |
| begin |
| Result := (FStorages.Count = 0); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropURLTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDropURLTarget.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| DragTypes := [dtCopy, dtLink]; |
| GetDataOnEnter := True; |
| FURLFormat := TURLDataFormat.Create(Self); |
| end; |
| destructor TDropURLTarget.Destroy; |
| begin |
| FURLFormat.Free; |
| inherited Destroy; |
| end; |
| function TDropURLTarget.GetTitle: string; |
| begin |
| Result := FURLFormat.Title; |
| end; |
| function TDropURLTarget.GetURL: string; |
| begin |
| Result := FURLFormat.URL; |
| end; |
| function TDropURLTarget.GetPreferredDropEffect: LongInt; |
| begin |
| Result := GetPreferredDropEffect; |
| if (Result = DROPEFFECT_NONE) then |
| Result := DROPEFFECT_LINK; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropURLSource |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDropURLSource.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| DragTypes := [dtCopy, dtLink]; |
| PreferredDropEffect := DROPEFFECT_LINK; |
| FURLFormat := TURLDataFormat.Create(Self); |
| end; |
| destructor TDropURLSource.Destroy; |
| begin |
| FURLFormat.Free; |
| inherited Destroy; |
| end; |
| function TDropURLSource.GetTitle: string; |
| begin |
| Result := FURLFormat.Title; |
| end; |
| procedure TDropURLSource.SetTitle(const Value: string); |
| begin |
| FURLFormat.Title := Value; |
| end; |
| function TDropURLSource.GetURL: string; |
| begin |
| Result := FURLFormat.URL; |
| end; |
| procedure TDropURLSource.SetURL(const Value: string); |
| begin |
| FURLFormat.URL := Value; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Initialization/Finalization |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| initialization |
| // Data format registration |
| TURLDataFormat.RegisterDataFormat; |
| THTMLDataFormat.RegisterDataFormat; |
| // Clipboard format registration |
| TURLDataFormat.RegisterCompatibleFormat(TNetscapeBookmarkClipboardFormat, 0, csSourceTarget, [ddRead]); |
| TURLDataFormat.RegisterCompatibleFormat(TNetscapeImageClipboardFormat, 1, csSourceTarget, [ddRead]); |
| TURLDataFormat.RegisterCompatibleFormat(TFileContentsClipboardFormat, 2, csSourceTarget, [ddRead]); |
| TURLDataFormat.RegisterCompatibleFormat(TFileGroupDescritorClipboardFormat, 2, csSourceTarget, [ddRead]); |
| TURLDataFormat.RegisterCompatibleFormat(TURLClipboardFormat, 2, csSourceTarget, [ddRead]); |
| TURLDataFormat.RegisterCompatibleFormat(TTextClipboardFormat, 3, csSourceTarget, [ddRead]); |
| TURLDataFormat.RegisterCompatibleFormat(TFileClipboardFormat, 4, [csTarget], [ddRead]); |
| THTMLDataFormat.RegisterCompatibleFormat(THTMLClipboardFormat, 0, csSourceTarget, [ddRead]); |
| TTextDataFormat.RegisterCompatibleFormat(TRFC822ClipboardFormat, 1, csSourceTarget, [ddRead]); |
| TTextDataFormat.RegisterCompatibleFormat(THTMLClipboardFormat, 2, csSourceTarget, [ddRead]); |
| finalization |
| // Clipboard format unregistration |
| TNetscapeBookmarkClipboardFormat.UnregisterClipboardFormat; |
| TNetscapeImageClipboardFormat.UnregisterClipboardFormat; |
| TURLClipboardFormat.UnregisterClipboardFormat; |
| TVCardClipboardFormat.UnregisterClipboardFormat; |
| THTMLClipboardFormat.UnregisterClipboardFormat; |
| TRFC822ClipboardFormat.UnregisterClipboardFormat; |
| // Target format unregistration |
| TURLDataFormat.UnregisterDataFormat; |
| end. |
| /trunk/VCL_DRAGDROP/DragDropPIDL.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DragDropPIDL.pas |
|---|
| 0,0 → 1,1029 |
| unit DragDropPIDL; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite |
| // Module: DragDropPIDL |
| // Description: Implements Dragging & Dropping of PIDLs (files and folders). |
| // Version: 4.0 |
| // Date: 18-MAY-2001 |
| // Target: Win32, Delphi 5-6 |
| // Authors: Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2001 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DragDrop, |
| DropTarget, |
| DropSource, |
| DragDropFormats, |
| DragDropFile, |
| Windows, |
| ActiveX, |
| Classes, |
| ShlObj; |
| {$include DragDrop.inc} |
| type |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TPIDLClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Supports the 'Shell IDList Array' format. |
| //////////////////////////////////////////////////////////////////////////////// |
| TPIDLClipboardFormat = class(TCustomSimpleClipboardFormat) |
| private |
| FPIDLs: TStrings; // Used internally to store PIDLs. We use strings to simplify cleanup. |
| FFilenames: TStrings; |
| protected |
| function ReadData(Value: pointer; Size: integer): boolean; override; |
| function WriteData(Value: pointer; Size: integer): boolean; override; |
| function GetSize: integer; override; |
| public |
| constructor Create; override; |
| destructor Destroy; override; |
| function GetClipboardFormat: TClipFormat; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| property PIDLs: TStrings read FPIDLs; |
| property Filenames: TStrings read FFilenames; |
| end; |
| type |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TPIDLDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TPIDLDataFormat = class(TCustomDataFormat) |
| private |
| FPIDLs : TStrings; |
| FFilenames : TStrings; |
| protected |
| public |
| constructor Create(AOwner: TDragDropComponent); override; |
| destructor Destroy; override; |
| function Assign(Source: TClipboardFormat): boolean; override; |
| function AssignTo(Dest: TClipboardFormat): boolean; override; |
| procedure Clear; override; |
| function HasData: boolean; override; |
| function NeedsData: boolean; override; |
| property PIDLs: TStrings read FPIDLs; |
| property Filenames: TStrings read FFilenames; |
| end; |
| type |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropPIDLTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropPIDLTarget = class(TCustomDropMultiTarget) |
| private |
| FPIDLDataFormat : TPIDLDataFormat; |
| FFileMapDataFormat : TFileMapDataFormat; |
| function GetFilenames: TStrings; |
| protected |
| function GetPIDLs: TStrings; |
| function GetPIDLCount: integer; |
| function GetMappedNames: TStrings; |
| property PIDLs: TStrings read GetPIDLs; |
| function DoGetPIDL(Index: integer): pItemIdList; |
| function GetPreferredDropEffect: LongInt; override; |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; Override; |
| // Note: It is the callers responsibility to cleanup |
| // the returned PIDLs from the following 3 methods: |
| // - GetFolderPidl |
| // - GetRelativeFilePidl |
| // - GetAbsoluteFilePidl |
| // Use the CoTaskMemFree procedure to free the PIDLs. |
| function GetFolderPIDL: pItemIdList; |
| function GetRelativeFilePIDL(Index: integer): pItemIdList; |
| function GetAbsoluteFilePIDL(Index: integer): pItemIdList; |
| property PIDLCount: integer read GetPIDLCount; // Includes folder pidl in count |
| // If you just want the filenames (not PIDLs) then use ... |
| property Filenames: TStrings read GetFilenames; |
| // MappedNames is only needed if files need to be renamed after a drag or |
| // e.g. dragging from 'Recycle Bin'. |
| property MappedNames: TStrings read GetMappedNames; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropPIDLSource |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropPIDLSource = class(TCustomDropMultiSource) |
| private |
| FPIDLDataFormat : TPIDLDataFormat; |
| FFileMapDataFormat : TFileMapDataFormat; |
| protected |
| function GetMappedNames: TStrings; |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; override; |
| procedure CopyFolderPIDLToList(pidl: PItemIDList); |
| procedure CopyFilePIDLToList(pidl: PItemIDList); |
| property MappedNames: TStrings read GetMappedNames; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // PIDL utility functions |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //: GetPIDLsFromData extracts a PIDL list from a memory block and stores the |
| // PIDLs in a string list. |
| function GetPIDLsFromData(Data: pointer; Size: integer; PIDLs: TStrings): boolean; |
| //: GetPIDLsFromHGlobal extracts a PIDL list from a global memory block and |
| // stores the PIDLs in a string list. |
| function GetPIDLsFromHGlobal(const HGlob: HGlobal; PIDLs: TStrings): boolean; |
| //: GetPIDLsFromFilenames converts a list of files to PIDLs and stores the |
| // PIDLs in a string list. All the PIDLs are relative to a common root. |
| function GetPIDLsFromFilenames(const Files: TStrings; PIDLs: TStrings): boolean; |
| //: GetRootFolderPIDL finds the PIDL of the folder which is the parent of a list |
| // of files. The PIDl is returned as a string. If the files do not share a |
| // common root, an empty string is returnde. |
| function GetRootFolderPIDL(const Files: TStrings): string; |
| //: GetFullPIDLFromPath converts a path (filename and path) to a folder/filename |
| // PIDL pair. |
| function GetFullPIDLFromPath(Path: string): pItemIDList; |
| //: GetFullPathFromPIDL converts a folder/filename PIDL pair to a full path. |
| function GetFullPathFromPIDL(PIDL: pItemIDList): string; |
| //: PIDLToString converts a single PIDL to a string. |
| function PIDLToString(pidl: PItemIDList): string; |
| //: StringToPIDL converts a PIDL string to a PIDL. |
| function StringToPIDL(const PIDL: string): PItemIDList; |
| //: JoinPIDLStrings merges two PIDL strings into one. |
| function JoinPIDLStrings(pidl1, pidl2: string): string; |
| //: ConvertFilesToShellIDList converts a list of files to a PIDL list. The |
| // files are relative to the folder specified by the Path parameter. The PIDLs |
| // are returned as a global memory handle. |
| function ConvertFilesToShellIDList(Path: string; Files: TStrings): HGlobal; |
| //: GetSizeOfPIDL calculates the size of a PIDL list. |
| function GetSizeOfPIDL(PIDL: pItemIDList): integer; |
| //: CopyPIDL makes a copy of a PIDL. |
| // It is the callers responsibility to free the returned PIDL. |
| function CopyPIDL(PIDL: pItemIDList): pItemIDList; |
| {$ifndef BCB} |
| // Undocumented PIDL utility functions... |
| // From http://www.geocities.com/SiliconValley/4942/ |
| function ILCombine(pidl1,pidl2:PItemIDList): PItemIDList; stdcall; |
| function ILFindLastID(pidl: PItemIDList): PItemIDList; stdcall; |
| function ILClone(pidl: PItemIDList): PItemIDList; stdcall; |
| function ILRemoveLastID(pidl: PItemIDList): LongBool; stdcall; |
| function ILIsEqual(pidl1,pidl2: PItemIDList): LongBool; stdcall; |
| procedure ILFree(Buffer: PItemIDList); stdcall; |
| // Undocumented IMalloc utility functions... |
| function SHAlloc(BufferSize: ULONG): Pointer; stdcall; |
| procedure SHFree(Buffer: Pointer); stdcall; |
| {$endif} |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // PIDL/IShellFolder utility functions |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //: GetShellFolderOfPath retrieves an IShellFolder interface which can be used |
| // to manage the specified folder. |
| function GetShellFolderOfPath(FolderPath: string): IShellFolder; |
| //: GetPIDLDisplayName retrieves the display name of the specified PIDL, |
| // relative to the specified folder. |
| function GetPIDLDisplayName(Folder: IShellFolder; PIDL: PItemIdList): string; |
| //: GetSubPIDL retrieves the PIDL of the specified file or folder to a PIDL. |
| // The PIDL is relative to the folder specified by the Folder parameter. |
| function GetSubPIDL(Folder: IShellFolder; Sub: string): pItemIDList; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| implementation |
| uses |
| ShellAPI, |
| SysUtils; |
| resourcestring |
| sNoFolderPIDL = 'Folder PIDL must be added first'; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| begin |
| RegisterComponents(DragDropComponentPalettePage, [TDropPIDLTarget, |
| TDropPIDLSource]); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // PIDL utility functions |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function GetPIDLsFromData(Data: pointer; Size: integer; PIDLs: TStrings): boolean; |
| var |
| i : integer; |
| pOffset : ^UINT; |
| PIDL : PItemIDList; |
| begin |
| PIDLs.Clear; |
| Result := (Data <> nil) and |
| (Size >= integer(PIDA(Data)^.cidl) * (SizeOf(UINT)+SizeOf(PItemIDList)) + SizeOf(UINT)); |
| if (not Result) then |
| exit; |
| pOffset := @(PIDA(Data)^.aoffset[0]); |
| i := PIDA(Data)^.cidl; // Note: Count doesn't include folder PIDL |
| while (i >= 0) do |
| begin |
| PIDL := PItemIDList(UINT(Data)+ pOffset^); |
| PIDLs.Add(PIDLToString(PIDL)); |
| inc(pOffset); |
| dec(i); |
| end; |
| Result := (PIDLs.Count > 1); |
| end; |
| function GetPIDLsFromHGlobal(const HGlob: HGlobal; PIDLs: TStrings): boolean; |
| var |
| pCIDA : PIDA; |
| begin |
| pCIDA := PIDA(GlobalLock(HGlob)); |
| try |
| Result := GetPIDLsFromData(pCIDA, GlobalSize(HGlob), PIDLs); |
| finally |
| GlobalUnlock(HGlob); |
| end; |
| end; |
| resourcestring |
| sBadDesktop = 'Failed to get interface to Desktop'; |
| sBadFilename = 'Invalid filename: %s'; |
| (* |
| ** Find the folder which is the parent of all the files in a list. |
| *) |
| function GetRootFolderPIDL(const Files: TStrings): string; |
| var |
| DeskTopFolder: IShellFolder; |
| WidePath: WideString; |
| PIDL: pItemIDList; |
| PIDLs: TStrings; |
| s: string; |
| PIDL1, PIDL2: pItemIDList; |
| Size, MaxSize: integer; |
| i: integer; |
| begin |
| Result := ''; |
| if (Files.Count = 0) then |
| exit; |
| if (SHGetDesktopFolder(DeskTopFolder) <> NOERROR) then |
| raise Exception.Create(sBadDesktop); |
| PIDLs := TStringList.Create; |
| try |
| // First convert all paths to PIDLs. |
| for i := 0 to Files.Count-1 do |
| begin |
| WidePath := ExtractFilePath(Files[i]); |
| if (DesktopFolder.ParseDisplayName(0, nil, PWideChar(WidePath), PULONG(nil)^, |
| PIDL, PULONG(nil)^) <> NOERROR) then |
| raise Exception.Create(sBadFilename); |
| try |
| PIDLs.Add(PIDLToString(PIDL)); |
| finally |
| coTaskMemFree(PIDL); |
| end; |
| end; |
| Result := PIDLs[0]; |
| MaxSize := Length(Result)-SizeOf(Word); |
| PIDL := pItemIDList(PChar(Result)); |
| for i := 1 to PIDLs.Count-1 do |
| begin |
| s := PIDLs[1]; |
| PIDL1 := PIDL; |
| PIDL2 := pItemIDList(PChar(s)); |
| Size := 0; |
| while (Size < MaxSize) and (PIDL1^.mkid.cb <> 0) and (PIDL1^.mkid.cb = PIDL2^.mkid.cb) and (CompareMem(PIDL1, PIDL2, PIDL1^.mkid.cb)) do |
| begin |
| inc(Size, PIDL1^.mkid.cb); |
| inc(integer(PIDL2), PIDL1^.mkid.cb); |
| inc(integer(PIDL1), PIDL1^.mkid.cb); |
| end; |
| if (Size <> MaxSize) then |
| begin |
| MaxSize := Size; |
| SetLength(Result, Size+SizeOf(Word)); |
| PIDL1^.mkid.cb := 0; |
| end; |
| if (Size = 0) then |
| break; |
| end; |
| finally |
| PIDLs.Free; |
| end; |
| end; |
| function GetPIDLsFromFilenames(const Files: TStrings; PIDLs: TStrings): boolean; |
| var |
| RootPIDL: string; |
| i: integer; |
| PIDL: pItemIdList; |
| FilePIDL: string; |
| begin |
| Result := False; |
| PIDLs.Clear; |
| if (Files.Count = 0) then |
| exit; |
| // Get the PIDL of the root folder... |
| // All the file PIDLs will be relative to this PIDL |
| RootPIDL := GetRootFolderPIDL(Files); |
| if (RootPIDL = '') then |
| exit; |
| Result := True; |
| PIDLS.Add(RootPIDL); |
| // Add the file PIDLs (all relative to the root)... |
| for i := 0 to Files.Count-1 do |
| begin |
| PIDL := GetFullPIDLFromPath(Files[i]); |
| if (PIDL = nil) then |
| begin |
| Result := False; |
| PIDLs.Clear; |
| break; |
| end; |
| try |
| FilePIDL := PIDLToString(PIDL); |
| finally |
| coTaskMemFree(PIDL); |
| end; |
| // Remove the root PIDL from the file PIDL making it relative to the root. |
| PIDLS.Add(copy(FilePIDL, Length(RootPIDL)-SizeOf(Word)+1, |
| Length(FilePIDL)-(Length(RootPIDL)-SizeOf(Word)))); |
| end; |
| end; |
| function GetSizeOfPIDL(PIDL: pItemIDList): integer; |
| var |
| Size: integer; |
| begin |
| if (PIDL <> nil) then |
| begin |
| Result := SizeOf(PIDL^.mkid.cb); |
| repeat |
| Size := PIDL^.mkid.cb; |
| inc(Result, Size); |
| inc(integer(PIDL), Size); |
| until (Size = 0); |
| end else |
| Result := 0; |
| end; |
| function CopyPIDL(PIDL: pItemIDList): pItemIDList; |
| var |
| Size: integer; |
| begin |
| Size := GetSizeOfPIDL(PIDL); |
| if (Size > 0) then |
| begin |
| Result := ShellMalloc.Alloc(Size); |
| if (Result <> nil) then |
| Move(PIDL^, Result^, Size); |
| end else |
| Result := nil; |
| end; |
| function GetFullPIDLFromPath(Path: string): pItemIDList; |
| var |
| DeskTopFolder : IShellFolder; |
| WidePath : WideString; |
| begin |
| WidePath := Path; |
| if (SHGetDesktopFolder(DeskTopFolder) = NOERROR) then |
| begin |
| if (DesktopFolder.ParseDisplayName(0, nil, PWideChar(WidePath), PULONG(nil)^, |
| Result, PULONG(nil)^) <> NOERROR) then |
| Result := nil; |
| end else |
| Result := nil; |
| end; |
| function GetFullPathFromPIDL(PIDL: pItemIDList): string; |
| var |
| Path: array[0..MAX_PATH] of char; |
| begin |
| if SHGetPathFromIDList(PIDL, Path) then |
| Result := Path |
| else |
| Result := ''; |
| end; |
| // See "Clipboard Formats for Shell Data Transfers" in Ole.hlp... |
| // (Needed to drag links (shortcuts).) |
| type |
| POffsets = ^TOffsets; |
| TOffsets = array[0..$FFFF] of UINT; |
| function ConvertFilesToShellIDList(Path: string; Files: TStrings): HGlobal; |
| var |
| shf: IShellFolder; |
| PathPidl, pidl: pItemIDList; |
| Ida: PIDA; |
| pOffset: POffsets; |
| ptrByte: ^Byte; |
| i, PathPidlSize, IdaSize, PreviousPidlSize: integer; |
| begin |
| Result := 0; |
| shf := GetShellFolderOfPath(path); |
| if shf = nil then |
| exit; |
| // Calculate size of IDA structure ... |
| // cidl: UINT ; Directory pidl |
| // offset: UINT ; all file pidl offsets |
| IdaSize := (Files.Count + 2) * SizeOf(UINT); |
| PathPidl := GetFullPIDLFromPath(path); |
| if PathPidl = nil then |
| exit; |
| try |
| PathPidlSize := GetSizeOfPidl(PathPidl); |
| //Add to IdaSize space for ALL pidls... |
| IdaSize := IdaSize + PathPidlSize; |
| for i := 0 to Files.Count-1 do |
| begin |
| pidl := GetSubPidl(shf, files[i]); |
| try |
| IdaSize := IdaSize + GetSizeOfPidl(Pidl); |
| finally |
| ShellMalloc.Free(pidl); |
| end; |
| end; |
| //Allocate memory... |
| Result := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, IdaSize); |
| if (Result = 0) then |
| exit; |
| try |
| Ida := GlobalLock(Result); |
| try |
| FillChar(Ida^, IdaSize, 0); |
| //Fill in offset and pidl data... |
| Ida^.cidl := Files.Count; //cidl = file count |
| pOffset := POffsets(@(Ida^.aoffset)); |
| pOffset^[0] := (Files.Count+2) * sizeof(UINT); //offset of Path pidl |
| ptrByte := pointer(Ida); |
| inc(ptrByte, pOffset^[0]); //ptrByte now points to Path pidl |
| Move(PathPidl^, ptrByte^, PathPidlSize); //copy path pidl |
| PreviousPidlSize := PathPidlSize; |
| for i := 1 to Files.Count do |
| begin |
| pidl := GetSubPidl(shf,files[i-1]); |
| try |
| pOffset^[i] := pOffset^[i-1] + UINT(PreviousPidlSize); //offset of pidl |
| PreviousPidlSize := GetSizeOfPidl(Pidl); |
| ptrByte := pointer(Ida); |
| inc(ptrByte, pOffset^[i]); //ptrByte now points to current file pidl |
| Move(Pidl^, ptrByte^, PreviousPidlSize); //copy file pidl |
| //PreviousPidlSize = current pidl size here |
| finally |
| ShellMalloc.Free(pidl); |
| end; |
| end; |
| finally |
| GlobalUnLock(Result); |
| end; |
| except |
| GlobalFree(Result); |
| raise; |
| end; |
| finally |
| ShellMalloc.Free(PathPidl); |
| end; |
| end; |
| function PIDLToString(pidl: PItemIDList): String; |
| var |
| PidlLength : integer; |
| begin |
| PidlLength := GetSizeOfPidl(pidl); |
| SetLength(Result, PidlLength); |
| Move(pidl^, PChar(Result)^, PidlLength); |
| end; |
| function StringToPIDL(const PIDL: string): PItemIDList; |
| begin |
| Result := ShellMalloc.Alloc(Length(PIDL)); |
| if (Result <> nil) then |
| Move(PChar(PIDL)^, Result^, Length(PIDL)); |
| end; |
| function JoinPIDLStrings(pidl1, pidl2: string): String; |
| var |
| PidlLength : integer; |
| begin |
| if Length(pidl1) <= 2 then |
| PidlLength := 0 |
| else |
| PidlLength := Length(pidl1)-2; |
| SetLength(Result, PidlLength + Length(pidl2)); |
| if PidlLength > 0 then |
| Move(PChar(pidl1)^, PChar(Result)^, PidlLength); |
| Move(PChar(pidl2)^, Result[PidlLength+1], Length(pidl2)); |
| end; |
| {$ifndef BCB} |
| // BCB appearantly doesn't support ordinal DLL imports. Strange! |
| function ILCombine(pidl1,pidl2:PItemIDList): PItemIDList; stdcall; |
| external shell32 index 25; |
| function ILFindLastID(pidl: PItemIDList): PItemIDList; stdcall; |
| external shell32 index 16; |
| function ILClone(pidl: PItemIDList): PItemIDList; stdcall; |
| external shell32 index 18; |
| function ILRemoveLastID(pidl: PItemIDList): LongBool; stdcall; |
| external shell32 index 17; |
| function ILIsEqual(pidl1,pidl2: PItemIDList): LongBool; stdcall; |
| external shell32 index 21; |
| procedure ILFree(Buffer: PItemIDList); stdcall; |
| external shell32 index 155; |
| function SHAlloc(BufferSize: ULONG): Pointer; stdcall; |
| external shell32 index 196; |
| procedure SHFree(Buffer: Pointer); stdcall; |
| external shell32 index 195; |
| {$endif} |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // PIDL/IShellFolder utility functions |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function GetShellFolderOfPath(FolderPath: string): IShellFolder; |
| var |
| DeskTopFolder: IShellFolder; |
| PathPidl: pItemIDList; |
| WidePath: WideString; |
| pdwAttributes: ULONG; |
| begin |
| Result := nil; |
| WidePath := FolderPath; |
| pdwAttributes := SFGAO_FOLDER; |
| if (SHGetDesktopFolder(DeskTopFolder) <> NOERROR) then |
| exit; |
| if (DesktopFolder.ParseDisplayName(0, nil, PWideChar(WidePath), PULONG(nil)^, |
| PathPidl, pdwAttributes) = NOERROR) then |
| try |
| if (pdwAttributes and SFGAO_FOLDER <> 0) then |
| DesktopFolder.BindToObject(PathPidl, nil, IID_IShellFolder, |
| // Note: For Delphi 4 and prior, the ppvOut parameter must be a pointer. |
| pointer(Result)); |
| finally |
| ShellMalloc.Free(PathPidl); |
| end; |
| end; |
| function GetSubPIDL(Folder: IShellFolder; Sub: string): pItemIDList; |
| var |
| WidePath: WideString; |
| begin |
| WidePath := Sub; |
| Folder.ParseDisplayName(0, nil, PWideChar(WidePath), PULONG(nil)^, Result, |
| PULONG(nil)^); |
| end; |
| function GetPIDLDisplayName(Folder: IShellFolder; PIDL: PItemIdList): string; |
| var |
| StrRet: TStrRet; |
| begin |
| Result := ''; |
| Folder.GetDisplayNameOf(PIDL, 0, StrRet); |
| case StrRet.uType of |
| STRRET_WSTR: Result := WideCharToString(StrRet.pOleStr); |
| STRRET_OFFSET: Result := PChar(UINT(PIDL)+StrRet.uOffset); |
| STRRET_CSTR: Result := StrRet.cStr; |
| end; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TPIDLsToFilenamesStrings |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Used internally to convert PIDLs to filenames on-demand. |
| //////////////////////////////////////////////////////////////////////////////// |
| type |
| TPIDLsToFilenamesStrings = class(TStrings) |
| private |
| FPIDLs: TStrings; |
| protected |
| function Get(Index: Integer): string; override; |
| function GetCount: Integer; override; |
| procedure Put(Index: Integer; const S: string); override; |
| procedure PutObject(Index: Integer; AObject: TObject); override; |
| public |
| constructor Create(APIDLs: TStrings); |
| procedure Clear; override; |
| procedure Delete(Index: Integer); override; |
| procedure Insert(Index: Integer; const S: string); override; |
| procedure Assign(Source: TPersistent); override; |
| end; |
| constructor TPIDLsToFilenamesStrings.Create(APIDLs: TStrings); |
| begin |
| inherited Create; |
| FPIDLs := APIDLs; |
| end; |
| function TPIDLsToFilenamesStrings.Get(Index: Integer): string; |
| var |
| PIDL: string; |
| Path: array [0..MAX_PATH] of char; |
| begin |
| if (Index < 0) or (Index > FPIDLs.Count-2) then |
| raise Exception.create('Filename index out of range'); |
| PIDL := JoinPIDLStrings(FPIDLs[0], FPIDLs[Index+1]); |
| if SHGetPathFromIDList(PItemIDList(PChar(PIDL)), Path) then |
| Result := Path |
| else |
| Result := ''; |
| end; |
| function TPIDLsToFilenamesStrings.GetCount: Integer; |
| begin |
| if FPIDLs.Count < 2 then |
| Result := 0 |
| else |
| Result := FPIDLs.Count-1; |
| end; |
| procedure TPIDLsToFilenamesStrings.Assign(Source: TPersistent); |
| begin |
| if Source is TStrings then |
| begin |
| BeginUpdate; |
| try |
| GetPIDLsFromFilenames(TStrings(Source), FPIDLs); |
| finally |
| EndUpdate; |
| end; |
| end else |
| inherited Assign(Source); |
| end; |
| // Inherited abstract methods which do not need implementation... |
| procedure TPIDLsToFilenamesStrings.Put(Index: Integer; const S: string); |
| begin |
| end; |
| procedure TPIDLsToFilenamesStrings.PutObject(Index: Integer; AObject: TObject); |
| begin |
| end; |
| procedure TPIDLsToFilenamesStrings.Clear; |
| begin |
| end; |
| procedure TPIDLsToFilenamesStrings.Delete(Index: Integer); |
| begin |
| end; |
| procedure TPIDLsToFilenamesStrings.Insert(Index: Integer; const S: string); |
| begin |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TPIDLClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TPIDLClipboardFormat.Create; |
| begin |
| inherited Create; |
| FPIDLs := TStringList.Create; |
| FFilenames := TPIDLsToFilenamesStrings.Create(FPIDLs); |
| end; |
| destructor TPIDLClipboardFormat.Destroy; |
| begin |
| FFilenames.Free; |
| FPIDLs.Free; |
| inherited Destroy; |
| end; |
| var |
| CF_IDLIST: TClipFormat = 0; |
| function TPIDLClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_IDLIST = 0) then |
| CF_IDLIST := RegisterClipboardFormat(CFSTR_SHELLIDLIST); |
| Result := CF_IDLIST; |
| end; |
| procedure TPIDLClipboardFormat.Clear; |
| begin |
| FPIDLs.Clear; |
| end; |
| function TPIDLClipboardFormat.HasData: boolean; |
| begin |
| Result := (FPIDLs.Count > 0); |
| end; |
| function TPIDLClipboardFormat.GetSize: integer; |
| var |
| i : integer; |
| begin |
| Result := (FPIDLs.Count+1) * SizeOf(UINT); |
| for i := 0 to FPIDLs.Count-1 do |
| inc(Result, Length(FPIDLs[i])); |
| end; |
| function TPIDLClipboardFormat.ReadData(Value: pointer; |
| Size: integer): boolean; |
| begin |
| Result := GetPIDLsFromData(Value, Size, FPIDLs); |
| end; |
| function TPIDLClipboardFormat.WriteData(Value: pointer; |
| Size: integer): boolean; |
| var |
| i : integer; |
| pCIDA : PIDA; |
| Offset : integer; |
| pOffset : ^UINT; |
| PIDL : PItemIDList; |
| begin |
| pCIDA := PIDA(Value); |
| pCIDA^.cidl := FPIDLs.Count-1; // Don't count folder PIDL |
| pOffset := @(pCIDA^.aoffset[0]); // Points to aoffset[0] |
| Offset := (FPIDLs.Count+1)*SizeOf(UINT); // Size of CIDA structure |
| PIDL := PItemIDList(integer(pCIDA) + Offset); // PIDLs are stored after CIDA structure. |
| for i := 0 to FPIDLs.Count-1 do |
| begin |
| pOffset^ := Offset; // Store relative offset of PIDL into aoffset[i] |
| // Copy the PIDL |
| Move(PChar(FPIDLs[i])^, PIDL^, length(FPIDLs[i])); |
| // Move on to next PIDL |
| inc(Offset, length(FPIDLs[i])); |
| inc(pOffset); |
| inc(integer(PIDL), length(FPIDLs[i])); |
| end; |
| Result := True; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TPIDLDataFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TPIDLDataFormat.Create(AOwner: TDragDropComponent); |
| begin |
| inherited Create(AOwner); |
| FPIDLs := TStringList.Create; |
| TStringList(FPIDLs).OnChanging := DoOnChanging; |
| FFilenames := TPIDLsToFilenamesStrings.Create(FPIDLs); |
| end; |
| destructor TPIDLDataFormat.Destroy; |
| begin |
| FFilenames.Free; |
| FPIDLs.Free; |
| inherited Destroy; |
| end; |
| function TPIDLDataFormat.Assign(Source: TClipboardFormat): boolean; |
| begin |
| Result := True; |
| if (Source is TPIDLClipboardFormat) then |
| FPIDLs.Assign(TPIDLClipboardFormat(Source).PIDLs) |
| else if (Source is TFileClipboardFormat) then |
| Result := GetPIDLsFromFilenames(TFileClipboardFormat(Source).Files, FPIDLs) |
| else |
| Result := inherited Assign(Source); |
| end; |
| function TPIDLDataFormat.AssignTo(Dest: TClipboardFormat): boolean; |
| begin |
| Result := True; |
| if (Dest is TPIDLClipboardFormat) then |
| TPIDLClipboardFormat(Dest).PIDLs.Assign(FPIDLs) |
| else if (Dest is TFileClipboardFormat) then |
| TFileClipboardFormat(Dest).Files.Assign(Filenames) |
| else |
| Result := inherited Assign(Dest); |
| end; |
| procedure TPIDLDataFormat.Clear; |
| begin |
| FPIDLs.Clear; |
| end; |
| function TPIDLDataFormat.HasData: boolean; |
| begin |
| Result := (FPIDLs.Count > 0); |
| end; |
| function TPIDLDataFormat.NeedsData: boolean; |
| begin |
| Result := (FPIDLs.Count = 0); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropPIDLTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDropPIDLTarget.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| FPIDLDataFormat := TPIDLDataFormat.Create(Self); |
| FFileMapDataFormat := TFileMapDataFormat.Create(Self); |
| end; |
| destructor TDropPIDLTarget.Destroy; |
| begin |
| FPIDLDataFormat.Free; |
| FFileMapDataFormat.Free; |
| inherited Destroy; |
| end; |
| function TDropPIDLTarget.GetPIDLs: TStrings; |
| begin |
| Result := FPIDLDataFormat.PIDLs; |
| end; |
| function TDropPIDLTarget.DoGetPIDL(Index: integer): pItemIdList; |
| var |
| PIDL : string; |
| begin |
| PIDL := PIDLs[Index]; |
| Result := ShellMalloc.Alloc(Length(PIDL)); |
| if (Result <> nil) then |
| Move(PChar(PIDL)^, Result^, Length(PIDL)); |
| end; |
| function TDropPIDLTarget.GetFolderPidl: pItemIdList; |
| begin |
| Result := DoGetPIDL(0); |
| end; |
| function TDropPIDLTarget.GetRelativeFilePidl(Index: integer): pItemIdList; |
| begin |
| Result := nil; |
| if (index < 1) then |
| exit; |
| Result := DoGetPIDL(Index); |
| end; |
| function TDropPIDLTarget.GetAbsoluteFilePidl(Index: integer): pItemIdList; |
| var |
| PIDL : string; |
| begin |
| Result := nil; |
| if (index < 1) then |
| exit; |
| PIDL := JoinPIDLStrings(PIDLs[0], PIDLs[Index]); |
| Result := ShellMalloc.Alloc(Length(PIDL)); |
| if (Result <> nil) then |
| Move(PChar(PIDL)^, Result^, Length(PIDL)); |
| end; |
| function TDropPIDLTarget.GetPIDLCount: integer; |
| begin |
| // Note: Includes folder PIDL in count! |
| Result := FPIDLDataFormat.PIDLs.Count; |
| end; |
| function TDropPIDLTarget.GetFilenames: TStrings; |
| begin |
| Result := FPIDLDataFormat.Filenames; |
| end; |
| function TDropPIDLTarget.GetMappedNames: TStrings; |
| begin |
| Result := FFileMapDataFormat.FileMaps; |
| end; |
| function TDropPIDLTarget.GetPreferredDropEffect: LongInt; |
| begin |
| Result := inherited GetPreferredDropEffect; |
| if (Result = DROPEFFECT_NONE) then |
| Result := DROPEFFECT_COPY; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropPIDLSource |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDropPIDLSource.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| FPIDLDataFormat := TPIDLDataFormat.Create(Self); |
| FFileMapDataFormat := TFileMapDataFormat.Create(Self); |
| end; |
| destructor TDropPIDLSource.Destroy; |
| begin |
| FPIDLDataFormat.Free; |
| FFileMapDataFormat.Free; |
| inherited Destroy; |
| end; |
| procedure TDropPIDLSource.CopyFolderPIDLToList(pidl: PItemIDList); |
| begin |
| //Note: Once the PIDL has been copied into the list it can be 'freed'. |
| FPIDLDataFormat.Clear; |
| FFileMapDataFormat.Clear; |
| FPIDLDataFormat.PIDLs.Add(PIDLToString(pidl)); |
| end; |
| procedure TDropPIDLSource.CopyFilePIDLToList(pidl: PItemIDList); |
| begin |
| // Note: Once the PIDL has been copied into the list it can be 'freed'. |
| // Make sure that folder pidl has been added. |
| if (FPIDLDataFormat.PIDLs.Count < 1) then |
| raise Exception.Create(sNoFolderPIDL); |
| FPIDLDataFormat.PIDLs.Add(PIDLToString(pidl)); |
| end; |
| function TDropPIDLSource.GetMappedNames: TStrings; |
| begin |
| Result := FFileMapDataFormat.FileMaps; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Initialization/Finalization |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| initialization |
| // Data format registration |
| TPIDLDataFormat.RegisterDataFormat; |
| // Clipboard format registration |
| TPIDLDataFormat.RegisterCompatibleFormat(TPIDLClipboardFormat, 0, csSourceTarget, [ddRead]); |
| TPIDLDataFormat.RegisterCompatibleFormat(TFileClipboardFormat, 1, csSourceTarget, [ddRead]); |
| finalization |
| TPIDLDataFormat.UnregisterDataFormat; |
| end. |
| /trunk/VCL_DRAGDROP/DragDropText.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DragDropText.pas |
|---|
| 0,0 → 1,442 |
| unit DragDropText; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite. |
| // Module: DragDropText |
| // Description: Implements Dragging and Dropping of different text formats. |
| // Version: 4.0 |
| // Date: 18-MAY-2001 |
| // Target: Win32, Delphi 5-6 |
| // Authors: Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2001 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DragDrop, |
| DropTarget, |
| DropSource, |
| DragDropFormats, |
| ActiveX, |
| Windows, |
| Classes; |
| type |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TRichTextClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TRichTextClipboardFormat = class(TCustomTextClipboardFormat) |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| function HasData: boolean; override; |
| function Assign(Source: TCustomDataFormat): boolean; override; |
| function AssignTo(Dest: TCustomDataFormat): boolean; override; |
| property Text; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TUnicodeTextClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TUnicodeTextClipboardFormat = class(TCustomWideTextClipboardFormat) |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| function Assign(Source: TCustomDataFormat): boolean; override; |
| function AssignTo(Dest: TCustomDataFormat): boolean; override; |
| property Text; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TOEMTextClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TOEMTextClipboardFormat = class(TCustomTextClipboardFormat) |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| function Assign(Source: TCustomDataFormat): boolean; override; |
| function AssignTo(Dest: TCustomDataFormat): boolean; override; |
| property Text; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCSVClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TCSVClipboardFormat = class(TCustomStringListClipboardFormat) |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| function Assign(Source: TCustomDataFormat): boolean; override; |
| function AssignTo(Dest: TCustomDataFormat): boolean; override; |
| property Lines; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TLocaleClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TLocaleClipboardFormat = class(TCustomDWORDClipboardFormat) |
| public |
| function GetClipboardFormat: TClipFormat; override; |
| function HasData: boolean; override; |
| function Assign(Source: TCustomDataFormat): boolean; override; |
| function AssignTo(Dest: TCustomDataFormat): boolean; override; |
| property Locale: DWORD read GetValueDWORD; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropTextTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropTextTarget = class(TCustomDropMultiTarget) |
| private |
| FTextFormat : TTextDataFormat; |
| protected |
| function GetText: string; |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; override; |
| property Text: string read GetText; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropTextSource |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropTextSource = class(TCustomDropMultiSource) |
| private |
| FTextFormat : TTextDataFormat; |
| protected |
| function GetText: string; |
| procedure SetText(const Value: string); |
| public |
| constructor Create(aOwner: TComponent); override; |
| destructor Destroy; override; |
| published |
| property Text: string read GetText write SetText; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Misc. |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function IsRTF(const s: string): boolean; |
| function MakeRTF(const s: string): string; |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // IMPLEMENTATION |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| implementation |
| uses |
| SysUtils; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| begin |
| RegisterComponents(DragDropComponentPalettePage, [TDropTextTarget, |
| TDropTextSource]); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Utilities |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function IsRTF(const s: string): boolean; |
| begin |
| // This probably isn't a valid test, but it will have to do until I have |
| // time to research the RTF specifications. |
| { TODO -oanme -cImprovement : Need a solid test for RTF format. } |
| Result := (AnsiStrLIComp(PChar(s), '{\rtf', 5) = 0); |
| end; |
| { TODO -oanme -cImprovement : Needs RTF to text conversion. Maybe ITextDocument can be used. } |
| function MakeRTF(const s: string): string; |
| begin |
| { TODO -oanme -cImprovement : Needs to escape \ in text to RTF conversion. } |
| { TODO -oanme -cImprovement : Needs better text to RTF conversion. } |
| if (not IsRTF(s)) then |
| Result := '{\rtf1\ansi ' + s + '}' |
| else |
| Result := s; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TRichTextClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_RTF: TClipFormat = 0; |
| function TRichTextClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| // Note: The string 'Rich Text Format', is also defined in the RichEdit |
| // unit as CF_RTF |
| if (CF_RTF = 0) then |
| CF_RTF := RegisterClipboardFormat('Rich Text Format'); // *** DO NOT LOCALIZE *** |
| Result := CF_RTF; |
| end; |
| function TRichTextClipboardFormat.HasData: boolean; |
| begin |
| Result := inherited HasData and IsRTF(Text); |
| end; |
| function TRichTextClipboardFormat.Assign(Source: TCustomDataFormat): boolean; |
| begin |
| if (Source is TTextDataFormat) then |
| begin |
| Text := MakeRTF(TTextDataFormat(Source).Text); |
| Result := True; |
| end else |
| Result := inherited Assign(Source); |
| end; |
| function TRichTextClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean; |
| begin |
| if (Dest is TTextDataFormat) then |
| begin |
| TTextDataFormat(Dest).Text := Text; |
| Result := True; |
| end else |
| Result := inherited AssignTo(Dest); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TUnicodeTextClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TUnicodeTextClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| Result := CF_UNICODETEXT; |
| end; |
| function TUnicodeTextClipboardFormat.Assign(Source: TCustomDataFormat): boolean; |
| begin |
| if (Source is TTextDataFormat) then |
| begin |
| Text := TTextDataFormat(Source).Text; |
| Result := True; |
| end else |
| Result := inherited Assign(Source); |
| end; |
| function TUnicodeTextClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean; |
| begin |
| if (Dest is TTextDataFormat) then |
| begin |
| TTextDataFormat(Dest).Text := Text; |
| Result := True; |
| end else |
| Result := inherited AssignTo(Dest); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TOEMTextClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TOEMTextClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| Result := CF_OEMTEXT; |
| end; |
| function TOEMTextClipboardFormat.Assign(Source: TCustomDataFormat): boolean; |
| var |
| OEMText : string; |
| begin |
| if (Source is TTextDataFormat) then |
| begin |
| // First convert ANSI string to OEM string... |
| SetLength(OEMText, Length(TTextDataFormat(Source).Text)); |
| CharToOemBuff(PChar(TTextDataFormat(Source).Text), PChar(OEMText), |
| Length(TTextDataFormat(Source).Text)); |
| // ...then assign OEM string |
| Text := OEMText; |
| Result := True; |
| end else |
| Result := inherited Assign(Source); |
| end; |
| function TOEMTextClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean; |
| var |
| AnsiText : string; |
| begin |
| if (Dest is TTextDataFormat) then |
| begin |
| // First convert OEM string to ANSI string... |
| SetLength(AnsiText, Length(Text)); |
| OemToCharBuff(PChar(Text), PChar(AnsiText), Length(Text)); |
| // ...then assign ANSI string |
| TTextDataFormat(Dest).Text := AnsiText; |
| Result := True; |
| end else |
| Result := inherited AssignTo(Dest); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCSVClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| var |
| CF_CSV: TClipFormat = 0; |
| function TCSVClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| if (CF_CSV = 0) then |
| CF_CSV := RegisterClipboardFormat('CSV'); // *** DO NOT LOCALIZE *** |
| Result := CF_CSV; |
| end; |
| function TCSVClipboardFormat.Assign(Source: TCustomDataFormat): boolean; |
| begin |
| if (Source is TTextDataFormat) then |
| begin |
| Lines.Text := TTextDataFormat(Source).Text; |
| Result := True; |
| end else |
| Result := inherited AssignTo(Source); |
| end; |
| function TCSVClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean; |
| begin |
| if (Dest is TTextDataFormat) then |
| begin |
| TTextDataFormat(Dest).Text := Lines.Text; |
| Result := True; |
| end else |
| Result := inherited AssignTo(Dest); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TLocaleClipboardFormat |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TLocaleClipboardFormat.GetClipboardFormat: TClipFormat; |
| begin |
| Result := CF_LOCALE; |
| end; |
| function TLocaleClipboardFormat.HasData: boolean; |
| begin |
| Result := (Locale <> 0); |
| end; |
| function TLocaleClipboardFormat.Assign(Source: TCustomDataFormat): boolean; |
| begin |
| // So far we have no one to play with... |
| Result := inherited Assign(Source); |
| end; |
| function TLocaleClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean; |
| begin |
| // So far we have no one to play with... |
| Result := inherited AssignTo(Dest); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropTextTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDropTextTarget.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| FTextFormat := TTextDataFormat.Create(Self); |
| end; |
| destructor TDropTextTarget.Destroy; |
| begin |
| FTextFormat.Free; |
| inherited Destroy; |
| end; |
| function TDropTextTarget.GetText: string; |
| begin |
| Result := FTextFormat.Text; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropTextSource |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDropTextSource.Create(aOwner: TComponent); |
| begin |
| inherited Create(aOwner); |
| FTextFormat := TTextDataFormat.Create(Self); |
| end; |
| destructor TDropTextSource.Destroy; |
| begin |
| FTextFormat.Free; |
| inherited Destroy; |
| end; |
| function TDropTextSource.GetText: string; |
| begin |
| Result := FTextFormat.Text; |
| end; |
| procedure TDropTextSource.SetText(const Value: string); |
| begin |
| FTextFormat.Text := Value; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Initialization/Finalization |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| initialization |
| // Clipboard format registration |
| TTextDataFormat.RegisterCompatibleFormat(TUnicodeTextClipboardFormat, 1, csSourceTarget, [ddRead]); |
| TTextDataFormat.RegisterCompatibleFormat(TRichTextClipboardFormat, 2, csSourceTarget, [ddRead]); |
| TTextDataFormat.RegisterCompatibleFormat(TOEMTextClipboardFormat, 2, csSourceTarget, [ddRead]); |
| TTextDataFormat.RegisterCompatibleFormat(TCSVClipboardFormat, 3, csSourceTarget, [ddRead]); |
| finalization |
| // Clipboard format unregistration |
| TUnicodeTextClipboardFormat.UnregisterClipboardFormat; |
| TRichTextClipboardFormat.UnregisterClipboardFormat; |
| TOEMTextClipboardFormat.UnregisterClipboardFormat; |
| TCSVClipboardFormat.UnregisterClipboardFormat; |
| end. |
| /trunk/VCL_DRAGDROP/DropBMPSource.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DropBMPSource.pas |
|---|
| 0,0 → 1,213 |
| unit DropBMPSource; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite |
| // Component Names: TDropBMPSource |
| // Module: DropBMPSource |
| // Description: Implements Dragging & Dropping of Bitmaps |
| // FROM your application to another. |
| // Version: 3.7 |
| // Date: 22-JUL-1999 |
| // Target: Win32, Delphi 3 - Delphi 5, C++ Builder 3, C++ Builder 4 |
| // Authors: Angus Johnson, ajohnson@rpi.net.au |
| // Anders Melander, anders@melander.dk |
| // http://www.melander.dk |
| // Copyright © 1997-99 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| // Acknowledgements: |
| // Thanks to Dieter Steinwedel for some help with DIBs. |
| // http://godard.oec.uni-osnabrueck.de/student_home/dsteinwe/delphi/DietersDelphiSite.htm |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DropSource, |
| Classes, Graphics, ActiveX; |
| {$include DragDrop.inc} |
| type |
| TDropBMPSource = class(TDropSource) |
| private |
| fBitmap: TBitmap; |
| procedure SetBitmap(Bmp: TBitmap); |
| protected |
| function DoGetData(const FormatEtcIn: TFormatEtc; OUT Medium: TStgMedium):HRESULT; Override; |
| public |
| constructor Create(aOwner: TComponent); Override; |
| destructor Destroy; Override; |
| function CutOrCopyToClipboard: boolean; Override; |
| published |
| property Bitmap: TBitmap Read fBitmap Write SetBitmap; |
| end; |
| procedure Register; |
| implementation |
| uses |
| Windows, |
| SysUtils, |
| ClipBrd; |
| procedure Register; |
| begin |
| RegisterComponents('DragDrop', [TDropBMPSource]); |
| end; |
| // ----------------------------------------------------------------------------- |
| // Miscellaneous DIB Function |
| // ----------------------------------------------------------------------------- |
| function GetHGlobalDIBFromBitmap(Bitmap: Graphics.TBitmap): HGlobal; |
| var |
| Stream: TMemoryStream; |
| DIB: pointer; |
| DIBSize: integer; |
| bfh: TBitmapFileHeader; |
| begin |
| Stream := TMemoryStream.Create; |
| try |
| //let Graphics.pas do the work... |
| Bitmap.SaveToStream(Stream); |
| //BitmapFileHeader will be discarded |
| DIBSize := Stream.Size - sizeof(TBitmapFileHeader); |
| Result:=GlobalAlloc(GMEM_MOVEABLE or GMEM_ZEROINIT or GMEM_SHARE, DIBSize); |
| if Result = 0 then exit; |
| DIB := GlobalLock(Result); |
| if DIB = nil then |
| begin |
| GlobalFree(Result); |
| Result := 0; |
| end else |
| begin |
| Stream.Seek(0,soFromBeginning); |
| //skip BitmapFileHeader... |
| Stream.readbuffer(bfh,sizeof(TBitmapFileHeader)); |
| //copy data... |
| Stream.readbuffer(DIB^,DIBSize); |
| GlobalUnlock(Result); |
| end; |
| finally |
| Stream.free; |
| end; |
| end; |
| // ----------------------------------------------------------------------------- |
| // TDropBMPSource |
| // ----------------------------------------------------------------------------- |
| constructor TDropBMPSource.Create(aOwner: TComponent); |
| begin |
| inherited Create(aOwner); |
| fBitmap := Graphics.TBitmap.Create; |
| DragTypes := [dtCopy]; // Default to Copy |
| AddFormatEtc(CF_BITMAP, NIL, DVASPECT_CONTENT, -1, TYMED_GDI); |
| AddFormatEtc(CF_PALETTE, NIL, DVASPECT_CONTENT, -1, TYMED_GDI); |
| AddFormatEtc(CF_DIB, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL); |
| end; |
| // ----------------------------------------------------------------------------- |
| destructor TDropBMPSource.destroy; |
| begin |
| fBitmap.Free; |
| inherited Destroy; |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TDropBMPSource.SetBitmap(Bmp: Graphics.TBitmap); |
| begin |
| fBitmap.assign(Bmp); |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropBMPSource.CutOrCopyToClipboard: boolean; |
| var |
| data: HGlobal; |
| begin |
| result := false; |
| if fBitmap.empty then exit; |
| try |
| data := GetHGlobalDIBFromBitmap(fBitmap); |
| if data = 0 then exit; |
| Clipboard.SetAsHandle(CF_DIB,data); |
| result := true; |
| except |
| raise Exception.create('Unable to copy BMP to clipboard.'); |
| end; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropBMPSource.DoGetData(const FormatEtcIn: TFormatEtc; OUT Medium: TStgMedium):HRESULT; |
| var |
| fmt: WORD; |
| pal: HPALETTE; |
| begin |
| Medium.tymed := 0; |
| Medium.UnkForRelease := nil; |
| Medium.HGlobal := 0; |
| //-------------------------------------------------------------------------- |
| if not fBitmap.empty and |
| (FormatEtcIn.cfFormat = CF_DIB) and |
| (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and |
| (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then |
| begin |
| try |
| Medium.HGlobal := GetHGlobalDIBFromBitmap(fBitmap); |
| if Medium.HGlobal <> 0 then |
| begin |
| Medium.tymed := TYMED_HGLOBAL; |
| result := S_OK |
| end else |
| result := E_OUTOFMEMORY; |
| except |
| result := E_OUTOFMEMORY; |
| end; |
| end |
| //-------------------------------------------------------------------------- |
| else if not fBitmap.empty and |
| (FormatEtcIn.cfFormat = CF_BITMAP) and |
| (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and |
| (FormatEtcIn.tymed and TYMED_GDI <> 0) then |
| begin |
| try |
| //This next line just gets a copy of the bitmap handle... |
| fBitmap.SaveToClipboardFormat(fmt, THandle(Medium.hBitmap), pal); |
| if pal <> 0 then DeleteObject(pal); |
| if Medium.hBitmap <> 0 then |
| begin |
| Medium.tymed := TYMED_GDI; |
| result := S_OK |
| end else |
| result := E_OUTOFMEMORY; |
| except |
| result := E_OUTOFMEMORY; |
| end; |
| end |
| //-------------------------------------------------------------------------- |
| else if not fBitmap.empty and |
| (FormatEtcIn.cfFormat = CF_PALETTE) and |
| (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and |
| (FormatEtcIn.tymed and TYMED_GDI <> 0) then |
| begin |
| try |
| Medium.hBitmap := CopyPalette(fBitmap.palette); |
| if Medium.hBitmap <> 0 then |
| begin |
| Medium.tymed := TYMED_GDI; |
| result := S_OK |
| end else |
| result := E_OUTOFMEMORY; |
| except |
| result := E_OUTOFMEMORY; |
| end {try} |
| end else |
| result := DV_E_FORMATETC; |
| end; |
| // ----------------------------------------------------------------------------- |
| // ----------------------------------------------------------------------------- |
| end. |
| /trunk/VCL_DRAGDROP/DropBMPTarget.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DropBMPTarget.pas |
|---|
| 0,0 → 1,182 |
| unit DropBMPTarget; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite |
| // Component Names: TDropBMPSource |
| // Module: DropBMPSource |
| // Description: Implements Dragging & Dropping of Bitmaps |
| // FROM your application to another. |
| // Version: 3.7 |
| // Date: 22-JUL-1999 |
| // Target: Win32, Delphi 3 - Delphi 5, C++ Builder 3, C++ Builder 4 |
| // Authors: Angus Johnson, ajohnson@rpi.net.au |
| // Anders Melander, anders@melander.dk |
| // http://www.melander.dk |
| // Copyright © 1997-99 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DropSource, |
| DropTarget, |
| Windows, Classes, Graphics, ActiveX; |
| {$include DragDrop.inc} |
| type |
| TDropBMPTarget = class(TDropTarget) |
| private |
| fBitmap: TBitmap; |
| protected |
| procedure ClearData; override; |
| function DoGetData: boolean; override; |
| function HasValidFormats: boolean; override; |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; override; |
| property Bitmap: TBitmap Read fBitmap; |
| end; |
| procedure Register; |
| procedure CopyDIBToBitmap(Bitmap: TBitmap; BitmapInfo: PBitmapInfo; DIBSize: integer); |
| implementation |
| const |
| DIBFormatEtc: TFormatEtc = (cfFormat: CF_DIB; |
| ptd: nil; dwAspect: DVASPECT_CONTENT; lindex: -1; tymed: TYMED_HGLOBAL); |
| BMPFormatEtc: TFormatEtc = (cfFormat: CF_BITMAP; |
| ptd: nil; dwAspect: DVASPECT_CONTENT; lindex: -1; tymed: TYMED_GDI); |
| PalFormatEtc: TFormatEtc = (cfFormat: CF_PALETTE; |
| ptd: nil; dwAspect: DVASPECT_CONTENT; lindex: -1; tymed: TYMED_GDI); |
| procedure Register; |
| begin |
| RegisterComponents('DragDrop', [TDropBMPTarget]); |
| end; |
| // ----------------------------------------------------------------------------- |
| // Miscellaneous DIB Function |
| // ----------------------------------------------------------------------------- |
| procedure CopyDIBToBitmap(Bitmap: TBitmap; BitmapInfo: PBitmapInfo; DIBSize: integer); |
| var |
| BitmapFileHeader : TBitmapFileHeader; |
| FileSize : integer; |
| InfoSize : integer; |
| Stream : TMemoryStream; |
| begin |
| // Write DIB to a stream in the BMP file format |
| Stream := TMemoryStream.Create; |
| try |
| FileSize := sizeof(TBitmapFileHeader) + DIBSize; |
| InfoSize := sizeof(TBitmapInfoHeader); |
| if (BitmapInfo^.bmiHeader.biBitCount > 8) then |
| begin |
| if ((BitmapInfo^.bmiHeader.biCompression and BI_BITFIELDS) <> 0) then |
| Inc(InfoSize, 12); |
| end else |
| Inc(InfoSize, sizeof(TRGBQuad) * (1 shl BitmapInfo^.bmiHeader.biBitCount)); |
| Stream.SetSize(FileSize); |
| // Initialize file header |
| FillChar(BitmapFileHeader, sizeof(TBitmapFileHeader), 0); |
| with BitmapFileHeader do |
| begin |
| bfType := $4D42; // 'BM' = Windows BMP signature |
| bfSize := FileSize; // File size (not needed) |
| bfOffBits := sizeof(TBitmapFileHeader) + InfoSize; // Offset of pixel data |
| end; |
| // Save file header |
| Stream.Write(BitmapFileHeader, sizeof(TBitmapFileHeader)); |
| // Save TBitmapInfo structure and pixel data |
| Stream.Write(BitmapInfo^, DIBSize); |
| // Rewind and load bitmap from stream |
| Stream.Position := 0; |
| Bitmap.LoadFromStream(Stream); |
| finally |
| Stream.Free; |
| end; |
| end; |
| // ----------------------------------------------------------------------------- |
| // TDropBMPTarget |
| // ----------------------------------------------------------------------------- |
| constructor TDropBMPTarget.Create( AOwner: TComponent ); |
| begin |
| inherited Create( AOwner ); |
| fBitmap := TBitmap.Create; |
| end; |
| // ----------------------------------------------------------------------------- |
| destructor TDropBMPTarget.Destroy; |
| begin |
| fBitmap.Free; |
| inherited Destroy; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropBMPTarget.HasValidFormats: boolean; |
| begin |
| result := (DataObject.QueryGetData(DIBFormatEtc) = S_OK) or |
| (DataObject.QueryGetData(BMPFormatEtc) = S_OK); |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TDropBMPTarget.ClearData; |
| begin |
| fBitmap.handle := 0; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropBMPTarget.DoGetData: boolean; |
| var |
| medium, medium2: TStgMedium; |
| DIBData: pointer; |
| begin |
| result := false; |
| //-------------------------------------------------------------------------- |
| if (DataObject.GetData(DIBFormatEtc, medium) = S_OK) then |
| begin |
| if (medium.tymed = TYMED_HGLOBAL) then |
| begin |
| DIBData := GlobalLock(medium.HGlobal); |
| try |
| CopyDIBToBitmap(fBitmap, DIBData, GlobalSize(Medium.HGlobal)); |
| result := true; |
| finally |
| GlobalUnlock(medium.HGlobal); |
| end; |
| end; |
| ReleaseStgMedium(medium); |
| end |
| //-------------------------------------------------------------------------- |
| else if (DataObject.GetData(BMPFormatEtc, medium) = S_OK) then |
| begin |
| try |
| if (medium.tymed <> TYMED_GDI) then exit; |
| if (DataObject.GetData(PalFormatEtc, medium2) = S_OK) then |
| begin |
| try |
| fBitmap.LoadFromClipboardFormat(CF_BITMAP, Medium.hBitmap, Medium2.hBitmap); |
| finally |
| ReleaseStgMedium(medium2); |
| end; |
| end |
| else |
| fBitmap.LoadFromClipboardFormat(CF_BITMAP, Medium.hBitmap, 0); |
| result := true; |
| finally |
| ReleaseStgMedium(medium); |
| end; |
| end |
| //-------------------------------------------------------------------------- |
| else |
| result := false; |
| end; |
| // ----------------------------------------------------------------------------- |
| // ----------------------------------------------------------------------------- |
| end. |
| /trunk/VCL_DRAGDROP/DropComboTarget.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DropComboTarget.pas |
|---|
| 0,0 → 1,192 |
| unit DropComboTarget; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite |
| // Module: DropComboTarget |
| // Description: Implements a swiss-army-knife drop target component. |
| // Version: 4.0 |
| // Date: 18-MAY-2001 |
| // Target: Win32, Delphi 5-6 |
| // Authors: Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2001 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DragDrop, |
| DropTarget, |
| DragDropFormats, |
| DragDropInternet, |
| DragDropGraphics, |
| DragDropFile, |
| DragDropText, |
| Classes, |
| Graphics, |
| ActiveX; |
| type |
| // Note: mfCustom is used to support DataFormatAdapters. |
| TComboFormatType = (mfText, mfFile, mfURL, mfBitmap, mfMetaFile, mfData, mfCustom); |
| TComboFormatTypes = set of TComboFormatType; |
| const |
| AllComboFormats = [mfText, mfFile, mfURL, mfBitmap, mfMetaFile, mfData]; |
| type |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropComboTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropComboTarget = class(TCustomDropMultiTarget) |
| private |
| FFileFormat : TFileDataFormat; |
| FFileMapFormat : TFileMapDataFormat; |
| FURLFormat : TURLDataFormat; |
| FBitmapFormat : TBitmapDataFormat; |
| FMetaFileFormat : TMetaFileDataFormat; |
| FTextFormat : TTextDataFormat; |
| FDataFormat : TDataStreamDataFormat; |
| FFormats : TComboFormatTypes; |
| protected |
| procedure DoAcceptFormat(const DataFormat: TCustomDataFormat; |
| var Accept: boolean); override; |
| function GetFiles: TStrings; |
| function GetTitle: string; |
| function GetURL: string; |
| function GetBitmap: TBitmap; |
| function GetMetaFile: TMetaFile; |
| function GetText: string; |
| function GetFileMaps: TStrings; |
| function GetStreams: TStreamList; |
| public |
| constructor Create(AOwner: TComponent); override; |
| property Files: TStrings read GetFiles; |
| property FileMaps: TStrings read GetFileMaps; |
| property URL: string read GetURL; |
| property Title: string read GetTitle; |
| property Bitmap: TBitmap read GetBitmap; |
| property MetaFile: TMetaFile read GetMetaFile; |
| property Text: string read GetText; |
| property Data: TStreamList read GetStreams; |
| published |
| property OnAcceptFormat; |
| property Formats: TComboFormatTypes read FFormats write FFormats default AllComboFormats; |
| end; |
| (* |
| ** *** WARNING *** |
| ** |
| ** The TDropMultiTarget component has been renamed to TDropComboTarget and |
| ** will be removed shortly. See the readme.txt file for instruction on how to |
| ** replace TDropMultiTarget with TDropComboTarget. |
| *) |
| TDropMultiTarget = class(TDropComboTarget); |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| implementation |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| begin |
| RegisterComponents(DragDropComponentPalettePage, [TDropComboTarget]); |
| RegisterNoIcon([TDropMultiTarget]); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropComboTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDropComboTarget.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| FFileFormat := TFileDataFormat.Create(Self); |
| FURLFormat := TURLDataFormat.Create(Self); |
| FBitmapFormat := TBitmapDataFormat.Create(Self); |
| FMetaFileFormat := TMetaFileDataFormat.Create(Self); |
| FTextFormat := TTextDataFormat.Create(Self); |
| FFileMapFormat := TFileMapDataFormat.Create(Self); |
| FDataFormat := TDataStreamDataFormat.Create(Self); |
| FFormats := AllComboFormats; |
| end; |
| procedure TDropComboTarget.DoAcceptFormat(const DataFormat: TCustomDataFormat; |
| var Accept: boolean); |
| begin |
| if (Accept) then |
| begin |
| if (DataFormat is TFileDataFormat) or (DataFormat is TFileMapDataFormat) then |
| Accept := (mfFile in FFormats) |
| else if (DataFormat is TURLDataFormat) then |
| Accept := (mfURL in FFormats) |
| else if (DataFormat is TBitmapDataFormat) then |
| Accept := (mfBitmap in FFormats) |
| else if (DataFormat is TMetaFileDataFormat) then |
| Accept := (mfMetaFile in FFormats) |
| else if (DataFormat is TTextDataFormat) then |
| Accept := (mfText in FFormats) |
| else if (DataFormat is TDataStreamDataFormat) then |
| Accept := (mfData in FFormats) |
| else |
| Accept := (mfCustom in FFormats) |
| end; |
| if (Accept) then |
| inherited DoAcceptFormat(DataFormat, Accept); |
| end; |
| function TDropComboTarget.GetBitmap: TBitmap; |
| begin |
| Result := FBitmapFormat.Bitmap; |
| end; |
| function TDropComboTarget.GetFileMaps: TStrings; |
| begin |
| Result := FFileMapFormat.FileMaps; |
| end; |
| function TDropComboTarget.GetFiles: TStrings; |
| begin |
| Result := FFileFormat.Files; |
| end; |
| function TDropComboTarget.GetMetaFile: TMetaFile; |
| begin |
| Result := FMetaFileFormat.MetaFile; |
| end; |
| function TDropComboTarget.GetStreams: TStreamList; |
| begin |
| Result := FDataFormat.Streams; |
| end; |
| function TDropComboTarget.GetText: string; |
| begin |
| Result := FTextFormat.Text; |
| end; |
| function TDropComboTarget.GetTitle: string; |
| begin |
| Result := FURLFormat.Title; |
| end; |
| function TDropComboTarget.GetURL: string; |
| begin |
| Result := FURLFormat.URL; |
| end; |
| end. |
| /trunk/VCL_DRAGDROP/DropFileSource3.pas |
|---|
| 0,0 → 1,195 |
| unit DropFileSource3; |
| // ----------------------------------------------------------------------------- |
| // |
| // *** NOT FOR RELEASE *** |
| // |
| // *** INTERNAL USE ONLY *** |
| // |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite |
| // Module: DropFileSource3 |
| // Description: Test case for deprecated TDropSource class. |
| // Version: 4.0 |
| // Date: 25-JUN-2000 |
| // Target: Win32, Delphi 3-6 and C++ Builder 3-5 |
| // Authors: Angus Johnson, ajohnson@rpi.net.au |
| // Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2000 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DragDrop, |
| DragDropPIDL, |
| DragDropFormats, |
| DragDropFile, |
| DropSource3, |
| ActiveX, Classes; |
| {$include DragDrop.inc} |
| type |
| TDropFileSourceX = class(TDropSource) |
| private |
| fFiles: TStrings; |
| fMappedNames: TStrings; |
| FFileClipboardFormat: TFileClipboardFormat; |
| FPIDLClipboardFormat: TPIDLClipboardFormat; |
| FPreferredDropEffectClipboardFormat: TPreferredDropEffectClipboardFormat; |
| FFilenameMapClipboardFormat: TFilenameMapClipboardFormat; |
| FFilenameMapWClipboardFormat: TFilenameMapWClipboardFormat; |
| procedure SetFiles(files: TStrings); |
| procedure SetMappedNames(names: TStrings); |
| protected |
| function DoGetData(const FormatEtcIn: TFormatEtc; |
| out Medium: TStgMedium):HRESULT; override; |
| function CutOrCopyToClipboard: boolean; override; |
| public |
| constructor Create(aOwner: TComponent); override; |
| destructor Destroy; override; |
| published |
| property Files: TStrings read fFiles write SetFiles; |
| //MappedNames is only needed if files need to be renamed during a drag op |
| //eg dragging from 'Recycle Bin'. |
| property MappedNames: TStrings read fMappedNames write SetMappedNames; |
| end; |
| procedure Register; |
| implementation |
| uses |
| Windows, |
| ShlObj, |
| SysUtils, |
| ClipBrd; |
| procedure Register; |
| begin |
| RegisterComponents(DragDropComponentPalettePage, [TDropFileSourceX]); |
| end; |
| // ----------------------------------------------------------------------------- |
| // ----------------------------------------------------------------------------- |
| // ----------------------------------------------------------------------------- |
| // ----------------------------------------------------------------------------- |
| constructor TDropFileSourceX.Create(aOwner: TComponent); |
| begin |
| inherited Create(aOwner); |
| fFiles := TStringList.Create; |
| fMappedNames := TStringList.Create; |
| FFileClipboardFormat := TFileClipboardFormat.Create; |
| FPIDLClipboardFormat := TPIDLClipboardFormat.Create; |
| FPreferredDropEffectClipboardFormat := TPreferredDropEffectClipboardFormat.Create; |
| FFilenameMapClipboardFormat := TFilenameMapClipboardFormat.Create; |
| FFilenameMapWClipboardFormat := TFilenameMapWClipboardFormat.Create; |
| AddFormatEtc(FFileClipboardFormat.GetClipboardFormat, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL); |
| AddFormatEtc(FPIDLClipboardFormat.GetClipboardFormat, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL); |
| AddFormatEtc(FPreferredDropEffectClipboardFormat.GetClipboardFormat, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL); |
| AddFormatEtc(FFilenameMapClipboardFormat.GetClipboardFormat, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL); |
| AddFormatEtc(FFilenameMapWClipboardFormat.GetClipboardFormat, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL); |
| end; |
| // ----------------------------------------------------------------------------- |
| destructor TDropFileSourceX.destroy; |
| begin |
| FFileClipboardFormat.Free; |
| FPIDLClipboardFormat.Free; |
| FPreferredDropEffectClipboardFormat.Free; |
| FFilenameMapClipboardFormat.Free; |
| FFilenameMapWClipboardFormat.Free; |
| fFiles.Free; |
| fMappedNames.free; |
| inherited Destroy; |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TDropFileSourceX.SetFiles(files: TStrings); |
| begin |
| fFiles.assign(files); |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TDropFileSourceX.SetMappedNames(names: TStrings); |
| begin |
| fMappedNames.assign(names); |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropFileSourceX.CutOrCopyToClipboard: boolean; |
| var |
| FormatEtcIn: TFormatEtc; |
| Medium: TStgMedium; |
| begin |
| FormatEtcIn.cfFormat := CF_HDROP; |
| FormatEtcIn.dwAspect := DVASPECT_CONTENT; |
| FormatEtcIn.tymed := TYMED_HGLOBAL; |
| if (Files.count = 0) then result := false |
| else if GetData(formatetcIn,Medium) = S_OK then |
| begin |
| Clipboard.SetAsHandle(CF_HDROP,Medium.hGlobal); |
| result := true; |
| end else result := false; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropFileSourceX.DoGetData(const FormatEtcIn: TFormatEtc; |
| out Medium: TStgMedium):HRESULT; |
| begin |
| Medium.tymed := 0; |
| Medium.UnkForRelease := NIL; |
| Medium.hGlobal := 0; |
| result := E_UNEXPECTED; |
| if fFiles.count = 0 then |
| exit; |
| //-------------------------------------------------------------------------- |
| if FFileClipboardFormat.AcceptFormat(FormatEtcIn) then |
| begin |
| FFileClipboardFormat.Files.Assign(FFiles); |
| if FFileClipboardFormat.SetDataToMedium(FormatEtcIn, Medium) then |
| result := S_OK; |
| end else |
| //-------------------------------------------------------------------------- |
| if FFilenameMapClipboardFormat.AcceptFormat(FormatEtcIn) then |
| begin |
| FFilenameMapClipboardFormat.FileMaps.Assign(fMappedNames); |
| if FFilenameMapClipboardFormat.SetDataToMedium(FormatEtcIn, Medium) then |
| result := S_OK; |
| end else |
| //-------------------------------------------------------------------------- |
| if FFilenameMapWClipboardFormat.AcceptFormat(FormatEtcIn) then |
| begin |
| FFilenameMapWClipboardFormat.FileMaps.Assign(fMappedNames); |
| if FFilenameMapWClipboardFormat.SetDataToMedium(FormatEtcIn, Medium) then |
| result := S_OK; |
| end else |
| //-------------------------------------------------------------------------- |
| if FPIDLClipboardFormat.AcceptFormat(FormatEtcIn) then |
| begin |
| FPIDLClipboardFormat.Filenames.Assign(FFiles); |
| if FPIDLClipboardFormat.SetDataToMedium(FormatEtcIn, Medium) then |
| result := S_OK; |
| end else |
| //-------------------------------------------------------------------------- |
| //This next format does not work for Win95 but should for Win98, WinNT ... |
| //It stops the shell from prompting (with a popup menu) for the choice of |
| //Copy/Move/Shortcut when performing a file 'Shortcut' onto Desktop or Explorer. |
| if FPreferredDropEffectClipboardFormat.AcceptFormat(FormatEtcIn) then |
| begin |
| FPreferredDropEffectClipboardFormat.Value := FeedbackEffect; |
| if FPreferredDropEffectClipboardFormat.SetDataToMedium(FormatEtcIn, Medium) then |
| result := S_OK; |
| end else |
| result := DV_E_FORMATETC; |
| end; |
| end. |
| /trunk/VCL_DRAGDROP/DropHandler.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DropHandler.pas |
|---|
| 0,0 → 1,182 |
| unit DropHandler; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite. |
| // Module: DropHandler |
| // Description: Implements Drop Handler Shell Extensions. |
| // Version: 4.0 |
| // Date: 18-MAY-2001 |
| // Target: Win32, Delphi 5-6 |
| // Authors: Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2001 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DragDrop, |
| DropTarget, |
| DragDropFile, |
| DragDropComObj, |
| ActiveX, |
| Windows, |
| Classes; |
| type |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropHandler |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Based on Angus Johnson's DropHandler demo. |
| //////////////////////////////////////////////////////////////////////////////// |
| // A typical drop handler session goes like this: |
| // 1. User drags one or more source files over a target file which has a |
| // registered drop handler. |
| // 2. The shell loads the drop handler module. |
| // 3. The shell instantiates the registered drop handler object as an in-process |
| // COM server. |
| // 4. The IPersistFile.Load method is called with the name of the target file. |
| // The target file name is stored in the TDropHandler.TargetFile property. |
| // 5. The IDropTarget.Enter method is called. This causes a TDropHandler.OnEnter |
| // event to be fired. |
| // 6. One of two things can happen next: |
| // a) The user drops the source files on the target file. |
| // The IDropTarget.Drop method is called. This causes a |
| // TDropHandler.OnDrop event to be fired. |
| // The names of the dropped files are stored in the TDropHandler.Files |
| // string list property. |
| // b) The user drags the source files away from the target file. |
| // The IDropTarget.Leave method is called. This causes a |
| // TDropHandler.OnLeave event to be fired. |
| // 7. The shell unloads the drop handler module (usually after a few seconds). |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropHandler = class(TDropFileTarget, IPersistFile) |
| private |
| FTargetFile: string; |
| protected |
| // IPersistFile implementation |
| function GetClassID(out classID: TCLSID): HResult; stdcall; |
| function IsDirty: HResult; stdcall; |
| function Load(pszFileName: POleStr; dwMode: Longint): HResult; stdcall; |
| function Save(pszFileName: POleStr; fRemember: BOOL): HResult; stdcall; |
| function SaveCompleted(pszFileName: POleStr): HResult; stdcall; |
| function GetCurFile(out pszFileName: POleStr): HResult; stdcall; |
| public |
| property TargetFile: string read FTargetFile; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropHandlerFactory |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // COM Class factory for TDropHandler. |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropHandlerFactory = class(TShellExtFactory) |
| protected |
| public |
| procedure UpdateRegistry(Register: Boolean); override; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Misc. |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // IMPLEMENTATION |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| implementation |
| uses |
| ComObj; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| begin |
| RegisterComponents(DragDropComponentPalettePage, [TDropHandler]); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Utilities |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropHandler |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TDropHandler.GetClassID(out classID: TCLSID): HResult; |
| begin |
| result := E_NOTIMPL; |
| end; |
| function TDropHandler.GetCurFile(out pszFileName: POleStr): HResult; |
| begin |
| result := E_NOTIMPL; |
| end; |
| function TDropHandler.IsDirty: HResult; |
| begin |
| result := S_FALSE; |
| end; |
| function TDropHandler.Load(pszFileName: POleStr; dwMode: Integer): HResult; |
| begin |
| FTargetFile := WideCharToString(pszFileName); |
| result := S_OK; |
| end; |
| function TDropHandler.Save(pszFileName: POleStr; fRemember: BOOL): HResult; |
| begin |
| result := E_NOTIMPL; |
| end; |
| function TDropHandler.SaveCompleted(pszFileName: POleStr): HResult; |
| begin |
| result := E_NOTIMPL; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropHandlerFactory |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure TDropHandlerFactory.UpdateRegistry(Register: Boolean); |
| begin |
| if Register then |
| begin |
| inherited UpdateRegistry(Register); |
| CreateRegKey(FileClass+'\shellex\DropHandler', '', GUIDToString(ClassID)); |
| end else |
| begin |
| RegDeleteKey(HKEY_CLASSES_ROOT, PChar(FileClass)); |
| inherited UpdateRegistry(Register); |
| end; |
| end; |
| end. |
| /trunk/VCL_DRAGDROP/DropPIDLSource.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DropPIDLSource.pas |
|---|
| 0,0 → 1,360 |
| unit DropPIDLSource; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite |
| // Component Names: TDropPIDLSource |
| // Module: DropPIDLSource |
| // Description: Implements Dragging & Dropping of PIDLs |
| // FROM your application to another. |
| // Version: 3.7 |
| // Date: 22-JUL-1999 |
| // Target: Win32, Delphi 3 - Delphi 5, C++ Builder 3, C++ Builder 4 |
| // Authors: Angus Johnson, ajohnson@rpi.net.au |
| // Anders Melander, anders@melander.dk |
| // http://www.melander.dk |
| // Copyright © 1997-99 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DropSource, |
| Classes, ActiveX, ShlObj; |
| {$include DragDrop.inc} |
| type |
| TDropPIDLSource = class(TDropSource) |
| private |
| fPIDLs: TStrings; //NOTE: contains folder PIDL as well as file PIDLs |
| fMappedNames: TStrings; |
| function GetFilename(index: integer): string; //used internally |
| procedure SetMappedNames(names: TStrings); |
| protected |
| function DoGetData(const FormatEtcIn: TFormatEtc; |
| OUT Medium: TStgMedium):HRESULT; Override; |
| function CutOrCopyToClipboard: boolean; Override; |
| public |
| constructor Create(aOwner: TComponent); Override; |
| destructor Destroy; Override; |
| procedure CopyFolderPidlToList(pidl: PItemIDList); |
| procedure CopyFilePidlToList(pidl: PItemIDList); |
| property MappedNames: TStrings read fMappedNames write SetMappedNames; |
| end; |
| procedure Register; |
| //Exposed as also used by DropPIDLTarget... |
| function PidlToString(pidl: PItemIDList): String; |
| function JoinPidlStrings(pidl1,pidl2: string): String; |
| implementation |
| uses |
| Windows, |
| SysUtils, |
| ClipBrd; |
| procedure Register; |
| begin |
| RegisterComponents('DragDrop', [TDropPIDLSource]); |
| end; |
| // ----------------------------------------------------------------------------- |
| // Miscellaneous Functions... |
| // ----------------------------------------------------------------------------- |
| function GetSizeOfPidl(pidl: PItemIDList): integer; |
| var |
| i: integer; |
| begin |
| result := SizeOf(Word); |
| repeat |
| i := pSHItemID(pidl)^.cb; |
| inc(result,i); |
| inc(longint(pidl),i); |
| until i = 0; |
| end; |
| // ----------------------------------------------------------------------------- |
| function PidlToString(pidl: PItemIDList): String; |
| var |
| PidlLength: integer; |
| begin |
| PidlLength := GetSizeOfPidl(pidl); |
| setlength(result,PidlLength); |
| Move(pidl^,pchar(result)^,PidlLength); |
| end; |
| // ----------------------------------------------------------------------------- |
| function JoinPidlStrings(pidl1,pidl2: string): String; |
| var |
| PidlLength: integer; |
| begin |
| if Length(pidl1) <= 2 then PidlLength := 0 |
| else PidlLength := Length(pidl1)-2; |
| setlength(result,PidlLength+length(pidl2)); |
| if PidlLength > 0 then Move(pidl1[1],result[1],PidlLength); |
| Move(pidl2[1],result[PidlLength+1],length(pidl2)); |
| end; |
| // ----------------------------------------------------------------------------- |
| // TDropPIDLSource |
| // ----------------------------------------------------------------------------- |
| constructor TDropPIDLSource.Create(aOwner: TComponent); |
| begin |
| inherited Create(aOwner); |
| fPIDLs := TStringList.create; |
| fMappedNames := TStringList.Create; |
| AddFormatEtc(CF_HDROP, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL); |
| AddFormatEtc(CF_IDLIST, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL); |
| AddFormatEtc(CF_PREFERREDDROPEFFECT, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL); |
| AddFormatEtc(CF_FILENAMEMAP, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL); |
| AddFormatEtc(CF_FILENAMEMAPW, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL); |
| end; |
| // ----------------------------------------------------------------------------- |
| destructor TDropPIDLSource.Destroy; |
| begin |
| fPIDLs.free; |
| fMappedNames.free; |
| inherited Destroy; |
| end; |
| // ----------------------------------------------------------------------------- |
| //this function is used internally by DoGetData()... |
| function TDropPIDLSource.GetFilename(index: integer): string; |
| var |
| PidlStr: string; |
| buff: array [0..MAX_PATH] of char; |
| begin |
| if (index < 1) or (index >= fPIDLs.count) then result := '' |
| else |
| begin |
| PidlStr := JoinPidlStrings(fPIDLs[0], fPIDLs[index]); |
| SHGetPathFromIDList(PItemIDList(pChar(PidlStr)),buff); |
| result := buff; |
| end; |
| end; |
| // ----------------------------------------------------------------------------- |
| //Note: Once the PIDL has been copied into the list it can be 'freed'. |
| procedure TDropPIDLSource.CopyFolderPidlToList(pidl: PItemIDList); |
| begin |
| fPIDLs.clear; |
| fMappedNames.clear; |
| fPIDLs.add(PidlToString(pidl)); |
| end; |
| // ----------------------------------------------------------------------------- |
| //Note: Once the PIDL has been copied into the list it can be 'freed'. |
| procedure TDropPIDLSource.CopyFilePidlToList(pidl: PItemIDList); |
| begin |
| if fPIDLs.count < 1 then exit; //no folder pidl has been added! |
| fPIDLs.add(PidlToString(pidl)); |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TDropPIDLSource.SetMappedNames(names: TStrings); |
| begin |
| fMappedNames.assign(names); |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropPIDLSource.CutOrCopyToClipboard: boolean; |
| var |
| FormatEtcIn: TFormatEtc; |
| Medium: TStgMedium; |
| begin |
| FormatEtcIn.cfFormat := CF_IDLIST; |
| FormatEtcIn.dwAspect := DVASPECT_CONTENT; |
| FormatEtcIn.tymed := TYMED_HGLOBAL; |
| if (fPIDLs.count < 2) then result := false |
| else if GetData(formatetcIn,Medium) = S_OK then |
| begin |
| Clipboard.SetAsHandle(CF_IDLIST,Medium.hGlobal); |
| result := true; |
| end else result := false; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropPIDLSource.DoGetData(const FormatEtcIn: TFormatEtc; |
| OUT Medium: TStgMedium):HRESULT; |
| var |
| i, MemSpace, CidaSize, Offset, StrLength: integer; |
| pCIDA: PIDA; |
| pInt: ^UINT; |
| pOffset: PChar; |
| DropEffect: ^DWORD; |
| dropfiles: pDropFiles; |
| fFiles: string; |
| pFileList: PChar; |
| pFileW: PWideChar; |
| begin |
| Medium.tymed := 0; |
| Medium.UnkForRelease := NIL; |
| Medium.hGlobal := 0; |
| if fPIDLs.count < 2 then result := E_UNEXPECTED |
| //-------------------------------------------------------------------------- |
| else if (FormatEtcIn.cfFormat = CF_HDROP) and |
| (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and |
| (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then |
| begin |
| fFiles := ''; |
| for i := 1 to fPIDLs.Count-1 do |
| AppendStr(fFiles,GetFilename(i)+#0); |
| AppendStr(fFiles,#0); |
| Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, |
| SizeOf(TDropFiles)+length(fFiles)); |
| if (Medium.hGlobal = 0) then |
| result:=E_OUTOFMEMORY |
| else |
| begin |
| Medium.tymed := TYMED_HGLOBAL; |
| dropfiles := GlobalLock(Medium.hGlobal); |
| try |
| dropfiles^.pfiles := SizeOf(TDropFiles); |
| dropfiles^.fwide := False; |
| longint(pFileList) := longint(dropfiles)+SizeOf(TDropFiles); |
| move(fFiles[1],pFileList^,length(fFiles)); |
| finally |
| GlobalUnlock(Medium.hGlobal); |
| end; |
| result := S_OK; |
| end; |
| end |
| //-------------------------------------------------------------------------- |
| else if (FormatEtcIn.cfFormat = CF_FILENAMEMAP) and |
| (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and |
| (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) and |
| //make sure there is a Mapped Name for each filename... |
| (fMappedNames.Count = fPidls.Count-1) then |
| begin |
| strlength := 0; |
| for i := 0 to fMappedNames.Count-1 do |
| Inc(strlength, Length(fMappedNames[i])+1); |
| Medium.hGlobal := |
| GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, strlength+1); |
| if (Medium.hGlobal = 0) then |
| result:=E_OUTOFMEMORY |
| else |
| begin |
| Medium.tymed := TYMED_HGLOBAL; |
| pFileList := GlobalLock(Medium.hGlobal); |
| try |
| for i := 0 to fMappedNames.Count-1 do |
| begin |
| StrPCopy(pFileList,fMappedNames[i]); |
| Inc(pFileList, Length(fMappedNames[i])+1); |
| end; |
| pFileList^ := #0; |
| finally |
| GlobalUnlock(Medium.hGlobal); |
| end; |
| result := S_OK; |
| end; |
| end |
| //-------------------------------------------------------------------------- |
| else if (FormatEtcIn.cfFormat = CF_FILENAMEMAPW) and |
| (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and |
| (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) and |
| //make sure there is a Mapped Name for each filename... |
| (fMappedNames.Count = fPidls.Count-1) then |
| begin |
| strlength := 2; |
| for i := 0 to fMappedNames.Count-1 do |
| Inc(strlength, (Length(fMappedNames[i])+1)*2); |
| Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, strlength); |
| if (Medium.hGlobal = 0) then |
| result:=E_OUTOFMEMORY |
| else |
| begin |
| Medium.tymed := TYMED_HGLOBAL; |
| pFileW := GlobalLock(Medium.hGlobal); |
| try |
| for i := 0 to fMappedNames.Count-1 do |
| begin |
| StringToWideChar(fMappedNames[i], |
| pFileW, (length(fMappedNames[i])+1)*2); |
| Inc(pFileW, Length(fMappedNames[i])+1); |
| end; |
| pFileW^ := #0; |
| finally |
| GlobalUnlock(Medium.hGlobal); |
| end; |
| result := S_OK; |
| end; |
| end |
| //-------------------------------------------------------------------------- |
| else if (FormatEtcIn.cfFormat = CF_IDLIST) and |
| (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and |
| (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then |
| begin |
| CidaSize := sizeof(UINT)*(1+fPIDLs.Count); //size of CIDA structure |
| MemSpace := CidaSize; |
| for i := 0 to fPIDLs.Count-1 do |
| Inc(MemSpace, Length(fPIDLs[i])); |
| Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, MemSpace); |
| if (Medium.hGlobal = 0) then |
| result := E_OUTOFMEMORY |
| else |
| begin |
| medium.tymed := TYMED_HGLOBAL; |
| pCIDA := PIDA(GlobalLock(Medium.hGlobal)); |
| try |
| pCIDA^.cidl := fPIDLs.count-1; //don't count folder |
| pInt := @(pCIDA^.aoffset); //points to aoffset[0]; |
| pOffset := pChar(pCIDA); |
| //move pOffset to point to the Folder PIDL location |
| inc(pOffset,CidaSize); |
| offset := CidaSize; |
| for i := 0 to fPIDLs.Count-1 do |
| begin |
| pInt^ := offset; //store 'offset' into aoffset[i] |
| //copy the PIDL into pOffset |
| Move(pointer(fPIDLs[i])^,pOffset^,length(fPIDLs[i])); |
| //increase 'offset' by the size of the last pidl |
| inc(offset,length(fPIDLs[i])); |
| inc(pInt); //increment the aoffset pointer |
| //move pOffset ready for the next PIDL |
| inc(pOffset,length(fPIDLs[i])); |
| end; |
| finally |
| GlobalUnlock(Medium.hGlobal); |
| end; |
| result := S_OK; |
| end; |
| end |
| //-------------------------------------------------------------------------- |
| else if (FormatEtcIn.cfFormat = CF_PREFERREDDROPEFFECT) and |
| (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and |
| (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then |
| begin |
| Medium.tymed := TYMED_HGLOBAL; |
| Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, SizeOf(DWORD)); |
| if Medium.hGlobal = 0 then |
| result:=E_OUTOFMEMORY |
| else |
| begin |
| DropEffect := GlobalLock(Medium.hGlobal); |
| try |
| DropEffect^ := DWORD(FeedbackEffect); |
| finally |
| GlobalUnLock(Medium.hGlobal); |
| end; |
| result := S_OK; |
| end; |
| end |
| //-------------------------------------------------------------------------- |
| else |
| result := DV_E_FORMATETC; |
| end; |
| // ----------------------------------------------------------------------------- |
| // ----------------------------------------------------------------------------- |
| end. |
| /trunk/VCL_DRAGDROP/DropPIDLTarget.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DropPIDLTarget.pas |
|---|
| 0,0 → 1,368 |
| unit DropPIDLTarget; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite |
| // Component Names: TDropPIDLTarget |
| // Module: DropPIDLTarget |
| // Description: Implements Dragging & Dropping of PIDLs |
| // TO your application from another. |
| // Version: 3.7 |
| // Date: 22-JUL-1999 |
| // Target: Win32, Delphi 3 - Delphi 5, C++ Builder 3, C++ Builder 4 |
| // Authors: Angus Johnson, ajohnson@rpi.net.au |
| // Anders Melander, anders@melander.dk |
| // http://www.melander.dk |
| // Copyright © 1997-99 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DropSource, DropTarget, |
| Classes, ActiveX, ShlObj; |
| {$include DragDrop.inc} |
| type |
| TDropPIDLTarget = class(TDropTarget) |
| private |
| PIDLFormatEtc, |
| fFileNameMapFormatEtc, |
| fFileNameMapWFormatEtc: TFormatEtc; |
| fPIDLs: TStrings; // Used internally to store PIDLs. I use strings to simplify cleanup. |
| fFiles: TStrings; // List of filenames (paths) |
| fMappedNames: TStrings; |
| function GetPidlCount: integer; |
| protected |
| procedure ClearData; override; |
| function DoGetData: boolean; override; |
| function HasValidFormats: boolean; override; |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; Override; |
| function GetFolderPidl: pItemIdList; |
| function GetRelativeFilePidl(index: integer): pItemIdList; |
| function GetAbsoluteFilePidl(index: integer): pItemIdList; |
| function PasteFromClipboard: longint; Override; |
| property PidlCount: integer read GetPidlCount; //includes folder pidl in count |
| //If you just want the filenames (not PIDLs) then use ... |
| property Filenames: TStrings read fFiles; |
| //MappedNames is only needed if files need to be renamed after a drag op |
| //eg dragging from 'Recycle Bin'. |
| property MappedNames: TStrings read fMappedNames; |
| end; |
| procedure Register; |
| implementation |
| uses |
| DropPIDLSource, |
| Windows, |
| SysUtils, |
| ClipBrd; |
| procedure Register; |
| begin |
| RegisterComponents('DragDrop', [TDropPIDLTarget]); |
| end; |
| // ----------------------------------------------------------------------------- |
| // Miscellaneous Functions... |
| // ----------------------------------------------------------------------------- |
| function GetPidlsFromHGlobal(const HGlob: HGlobal; var Pidls: TStrings): boolean; |
| var |
| i: integer; |
| pInt: ^UINT; |
| pCIDA: PIDA; |
| begin |
| result := false; |
| pCIDA := PIDA(GlobalLock(HGlob)); |
| try |
| pInt := @(pCIDA^.aoffset[0]); |
| for i := 0 to pCIDA^.cidl do |
| begin |
| Pidls.add(PidlToString(pointer(UINT(pCIDA)+ pInt^))); |
| inc(pInt); |
| end; |
| if Pidls.count > 1 then result := true; |
| finally |
| GlobalUnlock(HGlob); |
| end; |
| end; |
| {By implementing the following TStrings class, component processing is reduced.} |
| // ----------------------------------------------------------------------------- |
| // TPIDLTargetStrings |
| // ----------------------------------------------------------------------------- |
| type |
| TPIDLTargetStrings = class(TStrings) |
| private |
| DropPIDLTarget: TDropPIDLTarget; |
| protected |
| function Get(Index: Integer): string; override; |
| function GetCount: Integer; override; |
| procedure Put(Index: Integer; const S: string); override; |
| procedure PutObject(Index: Integer; AObject: TObject); override; |
| public |
| procedure Clear; override; |
| procedure Delete(Index: Integer); override; |
| procedure Insert(Index: Integer; const S: string); override; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TPIDLTargetStrings.Get(Index: Integer): string; |
| var |
| PidlStr: string; |
| buff: array [0..MAX_PATH] of char; |
| begin |
| with DropPIDLTarget do |
| begin |
| if (Index < 0) or (Index > fPIDLs.count-2) then |
| raise Exception.create('Filename index out of range'); |
| PidlStr := JoinPidlStrings(fPIDLs[0], fPIDLs[Index+1]); |
| if SHGetPathFromIDList(PItemIDList(pChar(PidlStr)),buff) then |
| result := buff else |
| result := ''; |
| end; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TPIDLTargetStrings.GetCount: Integer; |
| begin |
| with DropPIDLTarget do |
| if fPIDLs.count < 2 then |
| result := 0 else |
| result := fPIDLs.count-1; |
| end; |
| // ----------------------------------------------------------------------------- |
| //Overriden abstract methods which do not need implementation... |
| procedure TPIDLTargetStrings.Put(Index: Integer; const S: string); |
| begin |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TPIDLTargetStrings.PutObject(Index: Integer; AObject: TObject); |
| begin |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TPIDLTargetStrings.Clear; |
| begin |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TPIDLTargetStrings.Delete(Index: Integer); |
| begin |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TPIDLTargetStrings.Insert(Index: Integer; const S: string); |
| begin |
| end; |
| // ----------------------------------------------------------------------------- |
| // TDropPIDLTarget |
| // ----------------------------------------------------------------------------- |
| constructor TDropPIDLTarget.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| fPIDLs := TStringList.create; |
| fFiles := TPIDLTargetStrings.create; |
| TPIDLTargetStrings(fFiles).DropPIDLTarget := self; |
| fMappedNames := TStringList.Create; |
| //SHGetMalloc(fShellMalloc); |
| with PIDLFormatEtc do |
| begin |
| cfFormat := CF_IDLIST; |
| ptd := nil; |
| dwAspect := DVASPECT_CONTENT; |
| lindex := -1; |
| tymed := TYMED_HGLOBAL; |
| end; |
| with fFileNameMapFormatEtc do |
| begin |
| cfFormat := CF_FILENAMEMAP; |
| ptd := nil; |
| dwAspect := DVASPECT_CONTENT; |
| lindex := -1; |
| tymed := TYMED_HGLOBAL; |
| end; |
| with fFileNameMapWFormatEtc do |
| begin |
| cfFormat := CF_FILENAMEMAPW; |
| ptd := nil; |
| dwAspect := DVASPECT_CONTENT; |
| lindex := -1; |
| tymed := TYMED_HGLOBAL; |
| end; |
| end; |
| // ----------------------------------------------------------------------------- |
| destructor TDropPIDLTarget.Destroy; |
| begin |
| fPIDLs.free; |
| fFiles.free; |
| fMappedNames.free; |
| inherited Destroy; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropPIDLTarget.HasValidFormats: boolean; |
| begin |
| result := (DataObject.QueryGetData(PIDLFormatEtc) = S_OK); |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TDropPIDLTarget.ClearData; |
| begin |
| fPIDLs.clear; |
| fMappedNames.clear; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropPIDLTarget.DoGetData: boolean; |
| var |
| medium: TStgMedium; |
| pFilename: pChar; |
| pFilenameW: PWideChar; |
| sFilename: String; |
| begin |
| ClearData; |
| result := false; |
| //-------------------------------------------------------------------------- |
| if (DataObject.GetData(PIDLFormatEtc, medium) = S_OK) then |
| begin |
| try |
| if (medium.tymed <> TYMED_HGLOBAL) then exit; |
| result := GetPidlsFromHGlobal(medium.HGlobal,fPIDLs); |
| finally |
| ReleaseStgMedium(medium); |
| end; |
| if not result then exit; |
| //Now check for FileNameMapping as well ... |
| //-------------------------------------------------------------------------- |
| if (DataObject.GetData(fFileNameMapFormatEtc, medium) = S_OK) then |
| begin |
| try |
| if (medium.tymed = TYMED_HGLOBAL) then |
| begin |
| pFilename := GlobalLock(medium.HGlobal); |
| try |
| while true do |
| begin |
| sFilename := pFilename; |
| if sFilename = '' then break; |
| fMappedNames.add(sFilename); |
| inc(pFilename, length(sFilename)+1); |
| end; |
| if Filenames.count <> fMappedNames.count then |
| fMappedNames.clear; |
| finally |
| GlobalUnlock(medium.HGlobal); |
| end; |
| end; |
| finally |
| ReleaseStgMedium(medium); |
| end; |
| end |
| //WideChar support for WinNT... |
| else if (DataObject.GetData(fFileNameMapWFormatEtc, medium) = S_OK) then |
| try |
| if (medium.tymed = TYMED_HGLOBAL) then |
| begin |
| pFilenameW := GlobalLock(medium.HGlobal); |
| try |
| while true do |
| begin |
| sFilename := WideCharToString(pFilenameW); |
| if sFilename = '' then break; |
| fMappedNames.add(sFilename); |
| inc(pFilenameW, length(sFilename)+1); |
| end; |
| if fFiles.count <> fMappedNames.count then |
| fMappedNames.clear; |
| finally |
| GlobalUnlock(medium.HGlobal); |
| end; |
| end; |
| finally |
| ReleaseStgMedium(medium); |
| end; |
| end; |
| end; |
| // ----------------------------------------------------------------------------- |
| //Note: It is the component user's responsibility to cleanup |
| //the returned PIDLs from the following 3 methods. |
| //Use - CoTaskMemFree() - to free the PIDLs. |
| function TDropPIDLTarget.GetFolderPidl: pItemIdList; |
| begin |
| result :=nil; |
| if fPIDLs.count = 0 then exit; |
| result := ShellMalloc.alloc(length(fPIDLs[0])); |
| if result <> nil then |
| move(pChar(fPIDLs[0])^,result^,length(fPIDLs[0])); |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropPIDLTarget.GetRelativeFilePidl(index: integer): pItemIdList; |
| begin |
| result :=nil; |
| if (index < 1) or (index >= fPIDLs.count) then exit; |
| result := ShellMalloc.alloc(length(fPIDLs[index])); |
| if result <> nil then |
| move(pChar(fPIDLs[index])^,result^,length(fPIDLs[index])); |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropPIDLTarget.GetAbsoluteFilePidl(index: integer): pItemIdList; |
| var |
| s: string; |
| begin |
| result :=nil; |
| if (index < 1) or (index >= fPIDLs.count) then exit; |
| s := JoinPidlStrings(fPIDLs[0], fPIDLs[index]); |
| result := ShellMalloc.alloc(length(s)); |
| if result <> nil then |
| move(pChar(s)^,result^,length(s)); |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropPIDLTarget.PasteFromClipboard: longint; |
| var |
| Global: HGlobal; |
| Preferred: longint; |
| begin |
| result := DROPEFFECT_NONE; |
| if not ClipBoard.HasFormat(CF_IDLIST) then exit; |
| Global := Clipboard.GetAsHandle(CF_IDLIST); |
| fPIDLs.clear; |
| if not GetPidlsFromHGlobal(Global,fPidls) then exit; |
| Preferred := inherited PasteFromClipboard; |
| //if no Preferred DropEffect then return copy else return Preferred ... |
| if (Preferred = DROPEFFECT_NONE) then |
| result := DROPEFFECT_COPY else |
| result := Preferred; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropPIDLTarget.GetPidlCount: integer; |
| begin |
| result := fPidls.count; //Note: includes folder pidl in count! |
| end; |
| // ----------------------------------------------------------------------------- |
| // ----------------------------------------------------------------------------- |
| end. |
| /trunk/VCL_DRAGDROP/DropSource.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DropSource.pas |
|---|
| 0,0 → 1,1301 |
| unit DropSource; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite |
| // Module: DropSource |
| // Description: Implements Dragging & Dropping of data |
| // FROM your application to another. |
| // Version: 4.0 |
| // Date: 18-MAY-2001 |
| // Target: Win32, Delphi 5-6 |
| // Authors: Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2001 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| // General changes: |
| // - Some component glyphs has changed. |
| // |
| // TDropSource changes: |
| // - CutToClipboard and CopyToClipboard now uses OleSetClipboard. |
| // This means that descendant classes no longer needs to override the |
| // CutOrCopyToClipboard method. |
| // - New OnGetData event. |
| // - Changed to use new V4 architecture: |
| // * All clipboard format support has been removed from TDropSource, it has |
| // been renamed to TCustomDropSource and the old TDropSource has been |
| // modified to descend from TCustomDropSource and has moved to the |
| // DropSource3 unit. TDropSource is now supported for backwards |
| // compatibility only and will be removed in a future version. |
| // * A new TCustomDropMultiSource, derived from TCustomDropSource, uses the |
| // new architecture (with TClipboardFormat and TDataFormat) and is the new |
| // base class for all the drop source components. |
| // - TInterfacedComponent moved to DragDrop unit. |
| // ----------------------------------------------------------------------------- |
| // TODO -oanme -cCheckItOut : OleQueryLinkFromData |
| // TODO -oanme -cDocumentation : CutToClipboard and CopyToClipboard alters the value of PreferredDropEffect. |
| // TODO -oanme -cDocumentation : Clipboard must be flushed or emptied manually after CutToClipboard and CopyToClipboard. Automatic flush is not guaranteed. |
| // TODO -oanme -cDocumentation : Delete-on-paste. Why and How. |
| // TODO -oanme -cDocumentation : Optimized move. Why and How. |
| // TODO -oanme -cDocumentation : OnPaste event is only fired if target sets the "Paste Succeeded" clipboard format. Explorer does this for delete-on-paste move operations. |
| // TODO -oanme -cDocumentation : DragDetectPlus. Why and How. |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DragDrop, |
| DragDropFormats, |
| ActiveX, |
| Controls, |
| Windows, |
| Classes; |
| {$include DragDrop.inc} |
| type |
| TDragResult = (drDropCopy, drDropMove, drDropLink, drCancel, |
| drOutMemory, drAsync, drUnknown); |
| TDropEvent = procedure(Sender: TObject; DragType: TDragType; |
| var ContinueDrop: Boolean) of object; |
| //: TAfterDropEvent is fired after the target has finished processing a |
| // successfull drop. |
| // The Optimized parameter is True if the target either performed an operation |
| // other than a move or performed an "optimized move". In either cases, the |
| // source isn't required to delete the source data. |
| // If the Optimized parameter is False, the target performed an "unoptimized |
| // move" operation and the source is required to delete the source data to |
| // complete the move operation. |
| TAfterDropEvent = procedure(Sender: TObject; DragResult: TDragResult; |
| Optimized: Boolean) of object; |
| TFeedbackEvent = procedure(Sender: TObject; Effect: LongInt; |
| var UseDefaultCursors: Boolean) of object; |
| //: The TDropDataEvent event is fired when the target requests data from the |
| // drop source or offers data to the drop source. |
| // The Handled flag should be set if the event handler satisfied the request. |
| TDropDataEvent = procedure(Sender: TObject; const FormatEtc: TFormatEtc; |
| out Medium: TStgMedium; var Handled: Boolean) of object; |
| //: TPasteEvent is fired when the target sends a "Paste Succeeded" value |
| // back to the drop source after a clipboard transfer. |
| // The DeleteOnPaste parameter is True if the source is required to delete |
| // the source data. This will only occur after a CutToClipboard operation |
| // (corresponds to a move drag/drop). |
| TPasteEvent = procedure(Sender: TObject; Action: TDragResult; |
| DeleteOnPaste: boolean) of object; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomDropSource |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Abstract base class for all Drop Source components. |
| // Implements the IDropSource and IDataObject interfaces. |
| //////////////////////////////////////////////////////////////////////////////// |
| TCustomDropSource = class(TDragDropComponent, IDropSource, IDataObject, |
| IAsyncOperation) |
| private |
| FDragTypes: TDragTypes; |
| FFeedbackEffect: LongInt; |
| // Events... |
| FOnDrop: TDropEvent; |
| FOnAfterDrop: TAfterDropEvent; |
| FOnFeedback: TFeedBackEvent; |
| FOnGetData: TDropDataEvent; |
| FOnSetData: TDropDataEvent; |
| FOnPaste: TPasteEvent; |
| // Drag images... |
| FImages: TImageList; |
| FShowImage: boolean; |
| FImageIndex: integer; |
| FImageHotSpot: TPoint; |
| FDragSourceHelper: IDragSourceHelper; |
| // Async transfer... |
| FAllowAsync: boolean; |
| FRequestAsync: boolean; |
| FIsAsync: boolean; |
| protected |
| property FeedbackEffect: LongInt read FFeedbackEffect write FFeedbackEffect; |
| // IDropSource implementation |
| function QueryContinueDrag(fEscapePressed: bool; |
| grfKeyState: LongInt): HRESULT; stdcall; |
| function GiveFeedback(dwEffect: LongInt): HRESULT; stdcall; |
| // IDataObject implementation |
| function GetData(const FormatEtcIn: TFormatEtc; |
| out Medium: TStgMedium):HRESULT; stdcall; |
| function GetDataHere(const FormatEtc: TFormatEtc; |
| out Medium: TStgMedium):HRESULT; stdcall; |
| function QueryGetData(const FormatEtc: TFormatEtc): HRESULT; stdcall; |
| function GetCanonicalFormatEtc(const FormatEtc: TFormatEtc; |
| out FormatEtcout: TFormatEtc): HRESULT; stdcall; |
| function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; |
| fRelease: Bool): HRESULT; stdcall; |
| function EnumFormatEtc(dwDirection: LongInt; |
| out EnumFormatEtc: IEnumFormatEtc): HRESULT; stdcall; |
| function dAdvise(const FormatEtc: TFormatEtc; advf: LongInt; |
| const advsink: IAdviseSink; out dwConnection: LongInt): HRESULT; stdcall; |
| function dUnadvise(dwConnection: LongInt): HRESULT; stdcall; |
| function EnumdAdvise(out EnumAdvise: IEnumStatData): HRESULT; stdcall; |
| // IAsyncOperation implementation |
| function EndOperation(hResult: HRESULT; const pbcReserved: IBindCtx; |
| dwEffects: Cardinal): HRESULT; stdcall; |
| function GetAsyncMode(out fDoOpAsync: LongBool): HRESULT; stdcall; |
| function InOperation(out pfInAsyncOp: LongBool): HRESULT; stdcall; |
| function SetAsyncMode(fDoOpAsync: LongBool): HRESULT; stdcall; |
| function StartOperation(const pbcReserved: IBindCtx): HRESULT; stdcall; |
| // Abstract methods |
| function DoGetData(const FormatEtcIn: TFormatEtc; |
| out Medium: TStgMedium): HRESULT; virtual; abstract; |
| function DoSetData(const FormatEtc: TFormatEtc; |
| var Medium: TStgMedium): HRESULT; virtual; |
| function HasFormat(const FormatEtc: TFormatEtc): boolean; virtual; abstract; |
| function GetEnumFormatEtc(dwDirection: LongInt): IEnumFormatEtc; virtual; abstract; |
| // Data format event sink |
| procedure DataChanging(Sender: TObject); virtual; |
| // Clipboard |
| function CutOrCopyToClipboard: boolean; virtual; |
| procedure DoOnPaste(Action: TDragResult; DeleteOnPaste: boolean); virtual; |
| // Property access |
| procedure SetShowImage(Value: boolean); |
| procedure SetImages(const Value: TImageList); |
| procedure SetImageIndex(const Value: integer); |
| procedure SetPoint(Index: integer; Value: integer); |
| function GetPoint(Index: integer): integer; |
| function GetPerformedDropEffect: longInt; virtual; |
| function GetLogicalPerformedDropEffect: longInt; virtual; |
| procedure SetPerformedDropEffect(const Value: longInt); virtual; |
| function GetPreferredDropEffect: longInt; virtual; |
| procedure SetPreferredDropEffect(const Value: longInt); virtual; |
| function GetInShellDragLoop: boolean; virtual; |
| function GetTargetCLSID: TCLSID; virtual; |
| procedure SetInShellDragLoop(const Value: boolean); virtual; |
| function GetLiveDataOnClipboard: boolean; |
| procedure SetAllowAsync(const Value: boolean); |
| // Component management |
| procedure Notification(AComponent: TComponent; Operation: TOperation); override; |
| property DragSourceHelper: IDragSourceHelper read FDragSourceHelper; |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; override; |
| function Execute: TDragResult; virtual; |
| function CutToClipboard: boolean; virtual; |
| function CopyToClipboard: boolean; virtual; |
| procedure FlushClipboard; virtual; |
| procedure EmptyClipboard; virtual; |
| property PreferredDropEffect: longInt read GetPreferredDropEffect |
| write SetPreferredDropEffect; |
| property PerformedDropEffect: longInt read GetPerformedDropEffect |
| write SetPerformedDropEffect; |
| property LogicalPerformedDropEffect: longInt read GetLogicalPerformedDropEffect; |
| property InShellDragLoop: boolean read GetInShellDragLoop |
| write SetInShellDragLoop; |
| property TargetCLSID: TCLSID read GetTargetCLSID; |
| property LiveDataOnClipboard: boolean read GetLiveDataOnClipboard; |
| property AsyncTransfer: boolean read FIsAsync; |
| published |
| property DragTypes: TDragTypes read FDragTypes write FDragTypes; |
| // Events |
| property OnFeedback: TFeedbackEvent read FOnFeedback write FOnFeedback; |
| property OnDrop: TDropEvent read FOnDrop write FOnDrop; |
| property OnAfterDrop: TAfterDropEvent read FOnAfterDrop write FOnAfterDrop; |
| property OnGetData: TDropDataEvent read FOnGetData write FOnGetData; |
| property OnSetData: TDropDataEvent read FOnSetData write FOnSetData; |
| property OnPaste: TPasteEvent read FOnPaste write FOnPaste; |
| // Drag Images... |
| property Images: TImageList read FImages write SetImages; |
| property ImageIndex: integer read FImageIndex write SetImageIndex; |
| property ShowImage: boolean read FShowImage write SetShowImage; |
| property ImageHotSpotX: integer index 1 read GetPoint write SetPoint; |
| property ImageHotSpotY: integer index 2 read GetPoint write SetPoint; |
| // Async transfer... |
| property AllowAsyncTransfer: boolean read FAllowAsync write SetAllowAsync; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomDropMultiSource |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Drop target base class which can accept multiple formats. |
| //////////////////////////////////////////////////////////////////////////////// |
| TCustomDropMultiSource = class(TCustomDropSource) |
| private |
| FFeedbackDataFormat: TFeedbackDataFormat; |
| FRawDataFormat: TRawDataFormat; |
| protected |
| function DoGetData(const FormatEtcIn: TFormatEtc; |
| out Medium: TStgMedium):HRESULT; override; |
| function DoSetData(const FormatEtc: TFormatEtc; |
| var Medium: TStgMedium): HRESULT; override; |
| function HasFormat(const FormatEtc: TFormatEtc): boolean; override; |
| function GetEnumFormatEtc(dwDirection: LongInt): IEnumFormatEtc; override; |
| function GetPerformedDropEffect: longInt; override; |
| function GetLogicalPerformedDropEffect: longInt; override; |
| function GetPreferredDropEffect: longInt; override; |
| procedure SetPerformedDropEffect(const Value: longInt); override; |
| procedure SetPreferredDropEffect(const Value: longInt); override; |
| function GetInShellDragLoop: boolean; override; |
| procedure SetInShellDragLoop(const Value: boolean); override; |
| function GetTargetCLSID: TCLSID; override; |
| procedure DoOnSetData(DataFormat: TCustomDataFormat; |
| ClipboardFormat: TClipboardFormat); |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; override; |
| property DataFormats; |
| // TODO : Add support for delayed rendering with OnRenderData event. |
| published |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropEmptySource |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Do-nothing source for use with TDataFormatAdapter and such |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropEmptySource = class(TCustomDropMultiSource); |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropSourceThread |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Executes a drop source operation from a thread. |
| // TDropSourceThread is an alternative to the Windows 2000 Asynchronous Data |
| // Transfer support. |
| //////////////////////////////////////////////////////////////////////////////// |
| type |
| TDropSourceThread = class(TThread) |
| private |
| FDropSource: TCustomDropSource; |
| FDragResult: TDragResult; |
| protected |
| procedure Execute; override; |
| public |
| constructor Create(ADropSource: TCustomDropSource; AFreeOnTerminate: Boolean); |
| property DragResult: TDragResult read FDragResult; |
| property Terminated; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Utility functions |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function DropEffectToDragResult(DropEffect: longInt): TDragResult; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| (******************************************************************************* |
| ** |
| ** IMPLEMENTATION |
| ** |
| *******************************************************************************) |
| implementation |
| uses |
| CommCtrl, |
| ComObj, |
| Graphics; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| begin |
| RegisterComponents(DragDropComponentPalettePage, [TDropEmptySource]); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Utility functions |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function DropEffectToDragResult(DropEffect: longInt): TDragResult; |
| begin |
| case DropEffect of |
| DROPEFFECT_NONE: |
| Result := drCancel; |
| DROPEFFECT_COPY: |
| Result := drDropCopy; |
| DROPEFFECT_MOVE: |
| Result := drDropMove; |
| DROPEFFECT_LINK: |
| Result := drDropLink; |
| else |
| Result := drUnknown; // This is probably an error condition |
| end; |
| end; |
| // ----------------------------------------------------------------------------- |
| // TCustomDropSource |
| // ----------------------------------------------------------------------------- |
| constructor TCustomDropSource.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| DragTypes := [dtCopy]; //default to Copy. |
| // Note: Normally we would call _AddRef or coLockObjectExternal(Self) here to |
| // make sure that the component wasn't deleted prematurely (e.g. after a call |
| // to RegisterDragDrop), but since our ancestor class TInterfacedComponent |
| // disables reference counting, we do not need to do so. |
| FImageHotSpot := Point(16,16); |
| FImages := nil; |
| end; |
| destructor TCustomDropSource.Destroy; |
| begin |
| // TODO -oanme -cImprovement : Maybe FlushClipboard would be more appropiate? |
| EmptyClipboard; |
| inherited Destroy; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TCustomDropSource.GetCanonicalFormatEtc(const FormatEtc: TFormatEtc; |
| out FormatEtcout: TFormatEtc): HRESULT; |
| begin |
| Result := DATA_S_SAMEFORMATETC; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TCustomDropSource.SetData(const FormatEtc: TFormatEtc; |
| var Medium: TStgMedium; fRelease: Bool): HRESULT; |
| begin |
| // Warning: Ordinarily it would be much more efficient to just call |
| // HasFormat(FormatEtc) to determine if we support the given format, but |
| // because we have to able to accept *all* data formats, even unknown ones, in |
| // order to support the Windows 2000 drag helper functionality, we can't |
| // reject any formats here. Instead we pass the request on to DoSetData and |
| // let it worry about the details. |
| // if (HasFormat(FormatEtc)) then |
| // begin |
| try |
| Result := DoSetData(FormatEtc, Medium); |
| finally |
| if (fRelease) then |
| ReleaseStgMedium(Medium); |
| end; |
| // end else |
| // Result:= DV_E_FORMATETC; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TCustomDropSource.DAdvise(const FormatEtc: TFormatEtc; advf: LongInt; |
| const advSink: IAdviseSink; out dwConnection: LongInt): HRESULT; |
| begin |
| Result := OLE_E_ADVISENOTSUPPORTED; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TCustomDropSource.DUnadvise(dwConnection: LongInt): HRESULT; |
| begin |
| Result := OLE_E_ADVISENOTSUPPORTED; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TCustomDropSource.EnumDAdvise(out EnumAdvise: IEnumStatData): HRESULT; |
| begin |
| Result := OLE_E_ADVISENOTSUPPORTED; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TCustomDropSource.GetData(const FormatEtcIn: TFormatEtc; |
| out Medium: TStgMedium):HRESULT; stdcall; |
| var |
| Handled: boolean; |
| begin |
| Handled := False; |
| if (Assigned(FOnGetData)) then |
| // Fire event to ask user for data. |
| FOnGetData(Self, FormatEtcIn, Medium, Handled); |
| // If user provided data, there is no need to call descendant for it. |
| if (Handled) then |
| Result := S_OK |
| else if (HasFormat(FormatEtcIn)) then |
| // Call descendant class to get data. |
| Result := DoGetData(FormatEtcIn, Medium) |
| else |
| Result:= DV_E_FORMATETC; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TCustomDropSource.GetDataHere(const FormatEtc: TFormatEtc; |
| out Medium: TStgMedium):HRESULT; stdcall; |
| begin |
| Result := E_NOTIMPL; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TCustomDropSource.QueryGetData(const FormatEtc: TFormatEtc): HRESULT; stdcall; |
| begin |
| if (HasFormat(FormatEtc)) then |
| Result:= S_OK |
| else |
| Result:= DV_E_FORMATETC; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TCustomDropSource.EnumFormatEtc(dwDirection: LongInt; |
| out EnumFormatEtc:IEnumFormatEtc): HRESULT; stdcall; |
| begin |
| EnumFormatEtc := GetEnumFormatEtc(dwDirection); |
| if (EnumFormatEtc <> nil) then |
| Result := S_OK |
| else |
| Result := E_NOTIMPL; |
| end; |
| // ----------------------------------------------------------------------------- |
| // Implements IDropSource.QueryContinueDrag |
| function TCustomDropSource.QueryContinueDrag(fEscapePressed: bool; |
| grfKeyState: LongInt): HRESULT; stdcall; |
| var |
| ContinueDrop : Boolean; |
| DragType : TDragType; |
| begin |
| if FEscapePressed then |
| Result := DRAGDROP_S_CANCEL |
| // Allow drag and drop with either mouse buttons. |
| else if (grfKeyState and (MK_LBUTTON or MK_RBUTTON) = 0) then |
| begin |
| ContinueDrop := DropEffectToDragType(FeedbackEffect, DragType) and |
| (DragType in DragTypes); |
| InShellDragLoop := False; |
| // If a valid drop then do OnDrop event if assigned... |
| if ContinueDrop and Assigned(OnDrop) then |
| OnDrop(Self, DragType, ContinueDrop); |
| if ContinueDrop then |
| Result := DRAGDROP_S_DROP |
| else |
| Result := DRAGDROP_S_CANCEL; |
| end else |
| Result := S_OK; |
| end; |
| // ----------------------------------------------------------------------------- |
| // Implements IDropSource.GiveFeedback |
| function TCustomDropSource.GiveFeedback(dwEffect: LongInt): HRESULT; stdcall; |
| var |
| UseDefaultCursors: Boolean; |
| begin |
| UseDefaultCursors := True; |
| FeedbackEffect := dwEffect; |
| if Assigned(OnFeedback) then |
| OnFeedback(Self, dwEffect, UseDefaultCursors); |
| if UseDefaultCursors then |
| Result := DRAGDROP_S_USEDEFAULTCURSORS |
| else |
| Result := S_OK; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TCustomDropSource.DoSetData(const FormatEtc: TFormatEtc; |
| var Medium: TStgMedium): HRESULT; |
| var |
| Handled: boolean; |
| begin |
| Result := E_NOTIMPL; |
| if (Assigned(FOnSetData)) then |
| begin |
| Handled := False; |
| // Fire event to ask user to handle data. |
| FOnSetData(Self, FormatEtc, Medium, Handled); |
| if (Handled) then |
| Result := S_OK; |
| end; |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TCustomDropSource.SetAllowAsync(const Value: boolean); |
| begin |
| if (FAllowAsync <> Value) then |
| begin |
| FAllowAsync := Value; |
| if (not FAllowAsync) then |
| begin |
| FRequestAsync := False; |
| FIsAsync := False; |
| end; |
| end; |
| end; |
| function TCustomDropSource.GetAsyncMode(out fDoOpAsync: LongBool): HRESULT; |
| begin |
| fDoOpAsync := FRequestAsync; |
| Result := S_OK; |
| end; |
| function TCustomDropSource.SetAsyncMode(fDoOpAsync: LongBool): HRESULT; |
| begin |
| if (FAllowAsync) then |
| begin |
| FRequestAsync := fDoOpAsync; |
| Result := S_OK; |
| end else |
| Result := E_NOTIMPL; |
| end; |
| function TCustomDropSource.InOperation(out pfInAsyncOp: LongBool): HRESULT; |
| begin |
| pfInAsyncOp := FIsAsync; |
| Result := S_OK; |
| end; |
| function TCustomDropSource.StartOperation(const pbcReserved: IBindCtx): HRESULT; |
| begin |
| if (FRequestAsync) then |
| begin |
| FIsAsync := True; |
| Result := S_OK; |
| end else |
| Result := E_NOTIMPL; |
| end; |
| function TCustomDropSource.EndOperation(hResult: HRESULT; |
| const pbcReserved: IBindCtx; dwEffects: Cardinal): HRESULT; |
| var |
| DropResult: TDragResult; |
| begin |
| if (FIsAsync) then |
| begin |
| FIsAsync := False; |
| if (Assigned(FOnAfterDrop)) then |
| begin |
| if (Succeeded(hResult)) then |
| DropResult := DropEffectToDragResult(dwEffects and DragTypesToDropEffect(FDragTypes)) |
| else |
| DropResult := drUnknown; |
| FOnAfterDrop(Self, DropResult, |
| (DropResult <> drDropMove) or (PerformedDropEffect <> DROPEFFECT_MOVE)); |
| end; |
| Result := S_OK; |
| end else |
| Result := E_FAIL; |
| end; |
| function TCustomDropSource.Execute: TDragResult; |
| function GetRGBColor(Value: TColor): DWORD; |
| begin |
| Result := ColorToRGB(Value); |
| case Result of |
| clNone: Result := CLR_NONE; |
| clDefault: Result := CLR_DEFAULT; |
| end; |
| end; |
| var |
| DropResult: HRESULT; |
| AllowedEffects, |
| DropEffect: longint; |
| IsDraggingImage: boolean; |
| shDragImage: TSHDRAGIMAGE; |
| shDragBitmap: TBitmap; |
| begin |
| shDragBitmap := nil; |
| AllowedEffects := DragTypesToDropEffect(FDragTypes); |
| // Reset the "Performed Drop Effect" value. If it is supported by the target, |
| // the target will set it to the desired value when the drop occurs. |
| PerformedDropEffect := -1; |
| if (FShowImage) then |
| begin |
| // Attempt to create Drag Drop helper object. |
| // At present this is only supported on Windows 2000. If the object can't be |
| // created, we fall back to the old image list based method (which only |
| // works within the application). |
| CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, |
| IDragSourceHelper, FDragSourceHelper); |
| // Display drag image. |
| if (FDragSourceHelper <> nil) then |
| begin |
| IsDraggingImage := True; |
| shDragBitmap := TBitmap.Create; |
| shDragBitmap.PixelFormat := pfDevice; |
| FImages.GetBitmap(ImageIndex, shDragBitmap); |
| shDragImage.hbmpDragImage := shDragBitmap.Handle; |
| shDragImage.sizeDragImage.cx := shDragBitmap.Width; |
| shDragImage.sizeDragImage.cy := shDragBitmap.Height; |
| shDragImage.crColorKey := GetRGBColor(FImages.BkColor); |
| shDragImage.ptOffset.x := ImageHotSpotX; |
| shDragImage.ptOffset.y := ImageHotSpotY; |
| if Failed(FDragSourceHelper.InitializeFromBitmap(shDragImage, Self)) then |
| begin |
| FDragSourceHelper := nil; |
| shDragBitmap.Free; |
| shDragBitmap := nil; |
| end; |
| end else |
| IsDraggingImage := False; |
| // Fall back to image list drag image if platform doesn't support |
| // IDragSourceHelper or if we "just" failed to initialize properly. |
| if (FDragSourceHelper = nil) then |
| begin |
| IsDraggingImage := ImageList_BeginDrag(FImages.Handle, FImageIndex, |
| FImageHotSpot.X, FImageHotSpot.Y); |
| end; |
| end else |
| IsDraggingImage := False; |
| if (AllowAsyncTransfer) then |
| SetAsyncMode(True); |
| try |
| InShellDragLoop := True; |
| try |
| DropResult := DoDragDrop(Self, Self, AllowedEffects, DropEffect); |
| finally |
| // InShellDragLoop is also reset in TCustomDropSource.QueryContinueDrag. |
| // This is just to make absolutely sure that it is reset (actually no big |
| // deal if it isn't). |
| InShellDragLoop := False; |
| end; |
| finally |
| if IsDraggingImage then |
| begin |
| if (FDragSourceHelper <> nil) then |
| begin |
| FDragSourceHelper := nil; |
| shDragBitmap.Free; |
| end else |
| ImageList_EndDrag; |
| end; |
| end; |
| case DropResult of |
| DRAGDROP_S_DROP: |
| (* |
| ** Special handling of "optimized move". |
| ** If PerformedDropEffect has been set by the target to DROPEFFECT_MOVE |
| ** and the drop effect returned from DoDragDrop is different from |
| ** DROPEFFECT_MOVE, then an optimized move was performed. |
| ** Note: This is different from how MSDN states that an optimized move is |
| ** signalled, but matches how Windows 2000 signals an optimized move. |
| ** |
| ** On Windows 2000 an optimized move is signalled by: |
| ** 1) Returning DRAGDROP_S_DROP from DoDragDrop. |
| ** 2) Setting drop effect to DROPEFFECT_NONE. |
| ** 3) Setting the "Performed Dropeffect" format to DROPEFFECT_MOVE. |
| ** |
| ** On previous version of Windows, an optimized move is signalled by: |
| ** 1) Returning DRAGDROP_S_DROP from DoDragDrop. |
| ** 2) Setting drop effect to DROPEFFECT_MOVE. |
| ** 3) Setting the "Performed Dropeffect" format to DROPEFFECT_NONE. |
| ** |
| ** The documentation states that an optimized move is signalled by: |
| ** 1) Returning DRAGDROP_S_DROP from DoDragDrop. |
| ** 2) Setting drop effect to DROPEFFECT_NONE or DROPEFFECT_COPY. |
| ** 3) Setting the "Performed Dropeffect" format to DROPEFFECT_NONE. |
| *) |
| if (LogicalPerformedDropEffect = DROPEFFECT_MOVE) or |
| ((DropEffect <> DROPEFFECT_MOVE) and (PerformedDropEffect = DROPEFFECT_MOVE)) then |
| Result := drDropMove |
| else |
| Result := DropEffectToDragResult(DropEffect and AllowedEffects); |
| DRAGDROP_S_CANCEL: |
| Result := drCancel; |
| E_OUTOFMEMORY: |
| Result := drOutMemory; |
| else |
| // This should never happen! |
| Result := drUnknown; |
| end; |
| // Reset PerformedDropEffect if the target didn't set it. |
| if (PerformedDropEffect = -1) then |
| PerformedDropEffect := DROPEFFECT_NONE; |
| // Fire OnAfterDrop event unless we are in the middle of an async data |
| // transfer. |
| if (not AsyncTransfer) and (Assigned(FOnAfterDrop)) then |
| FOnAfterDrop(Self, Result, |
| (Result = drDropMove) and |
| ((DropEffect <> DROPEFFECT_MOVE) or (PerformedDropEffect <> DROPEFFECT_MOVE))); |
| end; |
| // ----------------------------------------------------------------------------- |
| function TCustomDropSource.GetPerformedDropEffect: longInt; |
| begin |
| Result := DROPEFFECT_NONE; |
| end; |
| function TCustomDropSource.GetLogicalPerformedDropEffect: longInt; |
| begin |
| Result := DROPEFFECT_NONE; |
| end; |
| procedure TCustomDropSource.SetPerformedDropEffect(const Value: longInt); |
| begin |
| // Not implemented in base class |
| end; |
| function TCustomDropSource.GetPreferredDropEffect: longInt; |
| begin |
| Result := DROPEFFECT_NONE; |
| end; |
| procedure TCustomDropSource.SetPreferredDropEffect(const Value: longInt); |
| begin |
| // Not implemented in base class |
| end; |
| function TCustomDropSource.GetInShellDragLoop: boolean; |
| begin |
| Result := False; |
| end; |
| function TCustomDropSource.GetTargetCLSID: TCLSID; |
| begin |
| Result := GUID_NULL; |
| end; |
| procedure TCustomDropSource.SetInShellDragLoop(const Value: boolean); |
| begin |
| // Not implemented in base class |
| end; |
| procedure TCustomDropSource.DataChanging(Sender: TObject); |
| begin |
| // Data is changing - Flush clipboard to freeze the contents |
| FlushClipboard; |
| end; |
| procedure TCustomDropSource.FlushClipboard; |
| begin |
| // If we have live data on the clipboard... |
| if (LiveDataOnClipboard) then |
| // ...we force the clipboard to make a static copy of the data |
| // before the data changes. |
| OleCheck(OleFlushClipboard); |
| end; |
| procedure TCustomDropSource.EmptyClipboard; |
| begin |
| // If we have live data on the clipboard... |
| if (LiveDataOnClipboard) then |
| // ...we empty the clipboard. |
| OleCheck(OleSetClipboard(nil)); |
| end; |
| function TCustomDropSource.CutToClipboard: boolean; |
| begin |
| PreferredDropEffect := DROPEFFECT_MOVE; |
| // Copy data to clipboard |
| Result := CutOrCopyToClipboard; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TCustomDropSource.CopyToClipboard: boolean; |
| begin |
| PreferredDropEffect := DROPEFFECT_COPY; |
| // Copy data to clipboard |
| Result := CutOrCopyToClipboard; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TCustomDropSource.CutOrCopyToClipboard: boolean; |
| begin |
| Result := (OleSetClipboard(Self as IDataObject) = S_OK); |
| end; |
| procedure TCustomDropSource.DoOnPaste(Action: TDragResult; DeleteOnPaste: boolean); |
| begin |
| if (Assigned(FOnPaste)) then |
| FOnPaste(Self, Action, DeleteOnPaste); |
| end; |
| function TCustomDropSource.GetLiveDataOnClipboard: boolean; |
| begin |
| Result := (OleIsCurrentClipboard(Self as IDataObject) = S_OK); |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TCustomDropSource.SetImages(const Value: TImageList); |
| begin |
| if (FImages = Value) then |
| exit; |
| FImages := Value; |
| if (csLoading in ComponentState) then |
| exit; |
| { DONE -oanme : Shouldn't FShowImage and FImageIndex only be reset if FImages = nil? } |
| if (FImages = nil) or (FImageIndex >= FImages.Count) then |
| FImageIndex := 0; |
| FShowImage := FShowImage and (FImages <> nil) and (FImages.Count > 0); |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TCustomDropSource.SetImageIndex(const Value: integer); |
| begin |
| if (csLoading in ComponentState) then |
| begin |
| FImageIndex := Value; |
| exit; |
| end; |
| if (Value < 0) or (FImages.Count = 0) or (FImages = nil) then |
| begin |
| FImageIndex := 0; |
| FShowImage := False; |
| end else |
| if (Value < FImages.Count) then |
| FImageIndex := Value; |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TCustomDropSource.SetPoint(Index: integer; Value: integer); |
| begin |
| if (Index = 1) then |
| FImageHotSpot.x := Value |
| else |
| FImageHotSpot.y := Value; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TCustomDropSource.GetPoint(Index: integer): integer; |
| begin |
| if (Index = 1) then |
| Result := FImageHotSpot.x |
| else |
| Result := FImageHotSpot.y; |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TCustomDropSource.SetShowImage(Value: boolean); |
| begin |
| FShowImage := Value; |
| if (csLoading in ComponentState) then |
| exit; |
| if (FImages = nil) then |
| FShowImage := False; |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TCustomDropSource.Notification(AComponent: TComponent; |
| Operation: TOperation); |
| begin |
| inherited Notification(AComponent, Operation); |
| if (Operation = opRemove) and (AComponent = FImages) then |
| Images := nil; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TEnumFormatEtc |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Format enumerator used by TCustomDropMultiTarget. |
| //////////////////////////////////////////////////////////////////////////////// |
| type |
| TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc) |
| private |
| FFormats : TClipboardFormats; |
| FIndex : integer; |
| protected |
| constructor CreateClone(AFormats: TClipboardFormats; AIndex: Integer); |
| public |
| constructor Create(AFormats: TDataFormats; Direction: TDataDirection); |
| { IEnumFormatEtc implentation } |
| function Next(Celt: LongInt; out Elt; pCeltFetched: pLongInt): HRESULT; stdcall; |
| function Skip(Celt: LongInt): HRESULT; stdcall; |
| function Reset: HRESULT; stdcall; |
| function Clone(out Enum: IEnumFormatEtc): HRESULT; stdcall; |
| end; |
| constructor TEnumFormatEtc.Create(AFormats: TDataFormats; Direction: TDataDirection); |
| var |
| i, j : integer; |
| begin |
| inherited Create; |
| FFormats := TClipboardFormats.Create(nil, False); |
| FIndex := 0; |
| for i := 0 to AFormats.Count-1 do |
| for j := 0 to AFormats[i].CompatibleFormats.Count-1 do |
| if (Direction in AFormats[i].CompatibleFormats[j].DataDirections) and |
| (not FFormats.Contain(TClipboardFormatClass(AFormats[i].CompatibleFormats[j].ClassType))) then |
| FFormats.Add(AFormats[i].CompatibleFormats[j]); |
| end; |
| constructor TEnumFormatEtc.CreateClone(AFormats: TClipboardFormats; AIndex: Integer); |
| var |
| i : integer; |
| begin |
| inherited Create; |
| FFormats := TClipboardFormats.Create(nil, False); |
| FIndex := AIndex; |
| for i := 0 to AFormats.Count-1 do |
| FFormats.Add(AFormats[i]); |
| end; |
| function TEnumFormatEtc.Next(Celt: LongInt; out Elt; |
| pCeltFetched: pLongInt): HRESULT; |
| var |
| i : integer; |
| FormatEtc : PFormatEtc; |
| begin |
| i := 0; |
| FormatEtc := PFormatEtc(@Elt); |
| while (i < Celt) and (FIndex < FFormats.Count) do |
| begin |
| FormatEtc^ := FFormats[FIndex].FormatEtc; |
| Inc(FormatEtc); |
| Inc(i); |
| Inc(FIndex); |
| end; |
| if (pCeltFetched <> nil) then |
| pCeltFetched^ := i; |
| if (i = Celt) then |
| Result := S_OK |
| else |
| Result := S_FALSE; |
| end; |
| function TEnumFormatEtc.Skip(Celt: LongInt): HRESULT; |
| begin |
| if (FIndex + Celt <= FFormats.Count) then |
| begin |
| inc(FIndex, Celt); |
| Result := S_OK; |
| end else |
| begin |
| FIndex := FFormats.Count; |
| Result := S_FALSE; |
| end; |
| end; |
| function TEnumFormatEtc.Reset: HRESULT; |
| begin |
| FIndex := 0; |
| Result := S_OK; |
| end; |
| function TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HRESULT; |
| begin |
| Enum := TEnumFormatEtc.CreateClone(FFormats, FIndex); |
| Result := S_OK; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomDropMultiSource |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| type |
| TSourceDataFormats = class(TDataFormats) |
| public |
| function Add(DataFormat: TCustomDataFormat): integer; override; |
| end; |
| function TSourceDataFormats.Add(DataFormat: TCustomDataFormat): integer; |
| begin |
| Result := inherited Add(DataFormat); |
| // Set up change notification so drop source can flush clipboard if data changes. |
| DataFormat.OnChanging := TCustomDropMultiSource(DataFormat.Owner).DataChanging; |
| end; |
| constructor TCustomDropMultiSource.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| FDataFormats := TSourceDataFormats.Create; |
| FFeedbackDataFormat := TFeedbackDataFormat.Create(Self); |
| FRawDataFormat := TRawDataFormat.Create(Self); |
| end; |
| destructor TCustomDropMultiSource.Destroy; |
| var |
| i : integer; |
| begin |
| EmptyClipboard; |
| // Delete all target formats owned by the object |
| for i := FDataFormats.Count-1 downto 0 do |
| FDataFormats[i].Free; |
| FDataFormats.Free; |
| inherited Destroy; |
| end; |
| function TCustomDropMultiSource.DoGetData(const FormatEtcIn: TFormatEtc; |
| out Medium: TStgMedium): HRESULT; |
| var |
| i, j: integer; |
| DF: TCustomDataFormat; |
| CF: TClipboardFormat; |
| begin |
| // TODO : Add support for delayed rendering with OnRenderData event. |
| Medium.tymed := 0; |
| Medium.UnkForRelease := nil; |
| Medium.hGlobal := 0; |
| Result := DV_E_FORMATETC; |
| (* |
| ** Loop through all data formats associated with this drop source to find one |
| ** which can offer the clipboard format requested by the target. |
| *) |
| for i := 0 to DataFormats.Count-1 do |
| begin |
| DF := DataFormats[i]; |
| // Ignore empty data formats. |
| if (not DF.HasData) then |
| continue; |
| (* |
| ** Loop through all the data format's supported clipboard formats to find |
| ** one which contains data and can provide it in the format requested by the |
| ** target. |
| *) |
| for j := 0 to DF.CompatibleFormats.Count-1 do |
| begin |
| CF := DF.CompatibleFormats[j]; |
| (* |
| ** 1) Determine if the clipboard format supports the format requested by |
| ** the target. |
| ** 2) Transfer data from the data format object to the clipboard format |
| ** object. |
| ** 3) Determine if the clipboard format object now has data to offer. |
| ** 4) Transfer the data from the clipboard format object to the medium. |
| *) |
| if (CF.AcceptFormat(FormatEtcIn)) and |
| (DataFormats[i].AssignTo(CF)) and |
| (CF.HasData) and |
| (CF.SetDataToMedium(FormatEtcIn, Medium)) then |
| begin |
| // Once data has been sucessfully transfered to the medium, we clear |
| // the data in the TClipboardFormat object in order to conserve |
| // resources. |
| CF.Clear; |
| Result := S_OK; |
| exit; |
| end; |
| end; |
| end; |
| end; |
| function TCustomDropMultiSource.DoSetData(const FormatEtc: TFormatEtc; |
| var Medium: TStgMedium): HRESULT; |
| var |
| i, j : integer; |
| GenericClipboardFormat: TRawClipboardFormat; |
| begin |
| Result := E_NOTIMPL; |
| // Get data for requested source format. |
| for i := 0 to DataFormats.Count-1 do |
| for j := 0 to DataFormats[i].CompatibleFormats.Count-1 do |
| if (DataFormats[i].CompatibleFormats[j].AcceptFormat(FormatEtc)) and |
| (DataFormats[i].CompatibleFormats[j].GetDataFromMedium(Self, Medium)) and |
| (DataFormats[i].Assign(DataFormats[i].CompatibleFormats[j])) then |
| begin |
| DoOnSetData(DataFormats[i], DataFormats[i].CompatibleFormats[j]); |
| // Once data has been sucessfully transfered to the medium, we clear |
| // the data in the TClipboardFormat object in order to conserve |
| // resources. |
| DataFormats[i].CompatibleFormats[j].Clear; |
| Result := S_OK; |
| exit; |
| end; |
| // The requested data format wasn't supported by any of the registered |
| // clipboard formats, but in order to support the Windows 2000 drag drop helper |
| // object we have to accept any data which is written to the IDataObject. |
| // To do this we create a new clipboard format object, initialize it with the |
| // format information passed to us and copy the data. |
| GenericClipboardFormat := TRawClipboardFormat.CreateFormatEtc(FormatEtc); |
| FRawDataFormat.CompatibleFormats.Add(GenericClipboardFormat); |
| if (GenericClipboardFormat.GetDataFromMedium(Self, Medium)) and |
| (FRawDataFormat.Assign(GenericClipboardFormat)) then |
| Result := S_OK; |
| end; |
| function TCustomDropMultiSource.GetEnumFormatEtc(dwDirection: Integer): IEnumFormatEtc; |
| begin |
| if (dwDirection = DATADIR_GET) then |
| Result := TEnumFormatEtc.Create(FDataFormats, ddRead) |
| else if (dwDirection = DATADIR_SET) then |
| Result := TEnumFormatEtc.Create(FDataFormats, ddWrite) |
| else |
| Result := nil; |
| end; |
| function TCustomDropMultiSource.HasFormat(const FormatEtc: TFormatEtc): boolean; |
| var |
| i , |
| j : integer; |
| begin |
| Result := False; |
| for i := 0 to DataFormats.Count-1 do |
| for j := 0 to DataFormats[i].CompatibleFormats.Count-1 do |
| if (DataFormats[i].CompatibleFormats[j].AcceptFormat(FormatEtc)) then |
| begin |
| Result := True; |
| exit; |
| end; |
| end; |
| function TCustomDropMultiSource.GetPerformedDropEffect: longInt; |
| begin |
| Result := FFeedbackDataFormat.PerformedDropEffect; |
| end; |
| function TCustomDropMultiSource.GetLogicalPerformedDropEffect: longInt; |
| begin |
| Result := FFeedbackDataFormat.LogicalPerformedDropEffect; |
| end; |
| function TCustomDropMultiSource.GetPreferredDropEffect: longInt; |
| begin |
| Result := FFeedbackDataFormat.PreferredDropEffect; |
| end; |
| procedure TCustomDropMultiSource.SetPerformedDropEffect(const Value: longInt); |
| begin |
| FFeedbackDataFormat.PerformedDropEffect := Value; |
| end; |
| procedure TCustomDropMultiSource.SetPreferredDropEffect(const Value: longInt); |
| begin |
| FFeedbackDataFormat.PreferredDropEffect := Value; |
| end; |
| function TCustomDropMultiSource.GetInShellDragLoop: boolean; |
| begin |
| Result := FFeedbackDataFormat.InShellDragLoop; |
| end; |
| procedure TCustomDropMultiSource.SetInShellDragLoop(const Value: boolean); |
| begin |
| FFeedbackDataFormat.InShellDragLoop := Value; |
| end; |
| function TCustomDropMultiSource.GetTargetCLSID: TCLSID; |
| begin |
| Result := FFeedbackDataFormat.TargetCLSID; |
| end; |
| procedure TCustomDropMultiSource.DoOnSetData(DataFormat: TCustomDataFormat; |
| ClipboardFormat: TClipboardFormat); |
| var |
| DropEffect : longInt; |
| begin |
| if (ClipboardFormat is TPasteSuccededClipboardFormat) then |
| begin |
| DropEffect := TPasteSuccededClipboardFormat(ClipboardFormat).Value; |
| DoOnPaste(DropEffectToDragResult(DropEffect), |
| (DropEffect = DROPEFFECT_MOVE) and (PerformedDropEffect = DROPEFFECT_MOVE)); |
| end; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropSourceThread |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TDropSourceThread.Create(ADropSource: TCustomDropSource; |
| AFreeOnTerminate: Boolean); |
| begin |
| inherited Create(True); |
| FreeOnTerminate := AFreeOnTerminate; |
| FDropSource := ADropSource; |
| FDragResult := drAsync; |
| end; |
| procedure TDropSourceThread.Execute; |
| var |
| pt: TPoint; |
| hwndAttach: HWND; |
| dwAttachThreadID, dwCurrentThreadID : DWORD; |
| begin |
| (* |
| ** See Microsoft Knowledgebase Article Q139408 for an explanation of the |
| ** AttachThreadInput stuff. |
| ** http://support.microsoft.com/support/kb/articles/Q139/4/08.asp |
| *) |
| // Get handle of window under mouse-cursor. |
| GetCursorPos(pt); |
| hwndAttach := WindowFromPoint(pt); |
| ASSERT(hwndAttach<>0, 'Can''t find window with drag-object'); |
| // Get thread IDs. |
| dwAttachThreadID := GetWindowThreadProcessId(hwndAttach, nil); |
| dwCurrentThreadID := GetCurrentThreadId(); |
| // Attach input queues if necessary. |
| if (dwAttachThreadID <> dwCurrentThreadID) then |
| AttachThreadInput(dwAttachThreadID, dwCurrentThreadID, True); |
| try |
| // Initialize OLE for this thread. |
| OleInitialize(nil); |
| try |
| // Start drag & drop. |
| FDragResult := FDropSource.Execute; |
| finally |
| OleUninitialize; |
| end; |
| finally |
| // Restore input queue settings. |
| if (dwAttachThreadID <> dwCurrentThreadID) then |
| AttachThreadInput(dwAttachThreadID, dwCurrentThreadID, False); |
| // Set Terminated flag so owner knows that drag has finished. |
| Terminate; |
| end; |
| end; |
| end. |
| /trunk/VCL_DRAGDROP/DropSource3.pas |
|---|
| 0,0 → 1,207 |
| unit DropSource3; |
| // ----------------------------------------------------------------------------- |
| // |
| // *** NOT FOR RELEASE *** |
| // |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite |
| // Module: DropSource3 |
| // Description: Deprecated TDropSource class. |
| // Provided for compatibility with previous versions of the |
| // Drag and Drop Component Suite. |
| // Version: 4.0 |
| // Date: 25-JUN-2000 |
| // Target: Win32, Delphi 3-6 and C++ Builder 3-5 |
| // Authors: Angus Johnson, ajohnson@rpi.net.au |
| // Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2000 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DragDrop, |
| DropSource, |
| ActiveX, |
| Classes; |
| {$include DragDrop.inc} |
| const |
| MAXFORMATS = 20; |
| type |
| // TODO -oanme -cStopShip : Verify that TDropSource can be used for pre v4 components. |
| TDropSource = class(TCustomDropSource) |
| private |
| FDataFormats: array[0..MAXFORMATS-1] of TFormatEtc; |
| FDataFormatsCount: integer; |
| protected |
| // IDataObject implementation |
| function QueryGetData(const FormatEtc: TFormatEtc): HRESULT; stdcall; |
| // TCustomDropSource implementation |
| function HasFormat(const FormatEtc: TFormatEtc): boolean; override; |
| function GetEnumFormatEtc(dwDirection: LongInt): IEnumFormatEtc; override; |
| // New functions... |
| procedure AddFormatEtc(cfFmt: TClipFormat; pt: PDVTargetDevice; |
| dwAsp, lInd, tym: longint); virtual; |
| public |
| constructor Create(AOwner: TComponent); override; |
| end; |
| implementation |
| uses |
| ShlObj, |
| SysUtils, |
| Windows; |
| // ----------------------------------------------------------------------------- |
| // TEnumFormatEtc |
| // ----------------------------------------------------------------------------- |
| type |
| pFormatList = ^TFormatList; |
| TFormatList = array[0..255] of TFormatEtc; |
| TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc) |
| private |
| FFormatList: pFormatList; |
| FFormatCount: Integer; |
| FIndex: Integer; |
| public |
| constructor Create(FormatList: pFormatList; FormatCount, Index: Integer); |
| { IEnumFormatEtc } |
| function Next(Celt: LongInt; out Elt; pCeltFetched: pLongInt): HRESULT; stdcall; |
| function Skip(Celt: LongInt): HRESULT; stdcall; |
| function Reset: HRESULT; stdcall; |
| function Clone(out Enum: IEnumFormatEtc): HRESULT; stdcall; |
| end; |
| // ----------------------------------------------------------------------------- |
| constructor TEnumFormatEtc.Create(FormatList: pFormatList; |
| FormatCount, Index: Integer); |
| begin |
| inherited Create; |
| FFormatList := FormatList; |
| FFormatCount := FormatCount; |
| FIndex := Index; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TEnumFormatEtc.Next(Celt: LongInt; |
| out Elt; pCeltFetched: pLongInt): HRESULT; |
| var |
| i: Integer; |
| begin |
| i := 0; |
| WHILE (i < Celt) and (FIndex < FFormatCount) do |
| begin |
| TFormatList(Elt)[i] := FFormatList[fIndex]; |
| Inc(FIndex); |
| Inc(i); |
| end; |
| if pCeltFetched <> NIL then pCeltFetched^ := i; |
| if i = Celt then result := S_OK else result := S_FALSE; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TEnumFormatEtc.Skip(Celt: LongInt): HRESULT; |
| begin |
| if Celt <= FFormatCount - FIndex then |
| begin |
| FIndex := FIndex + Celt; |
| result := S_OK; |
| end else |
| begin |
| FIndex := FFormatCount; |
| result := S_FALSE; |
| end; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TEnumFormatEtc.ReSet: HRESULT; |
| begin |
| fIndex := 0; |
| result := S_OK; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HRESULT; |
| begin |
| enum := TEnumFormatEtc.Create(FFormatList, FFormatCount, FIndex); |
| result := S_OK; |
| end; |
| // ----------------------------------------------------------------------------- |
| // TDropSource |
| // ----------------------------------------------------------------------------- |
| constructor TDropSource.Create(AOwner: TComponent); |
| begin |
| inherited Create(aOwner); |
| FDataFormatsCount := 0; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropSource.QueryGetData(const FormatEtc: TFormatEtc): HRESULT; stdcall; |
| var |
| i: integer; |
| begin |
| result:= S_OK; |
| for i := 0 to FDataFormatsCount-1 do |
| with FDataFormats[i] do |
| begin |
| if (FormatEtc.cfFormat = cfFormat) and |
| (FormatEtc.dwAspect = dwAspect) and |
| (FormatEtc.tymed and tymed <> 0) then exit; //result:= S_OK; |
| end; |
| result:= E_FAIL; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropSource.GetEnumFormatEtc(dwDirection: Integer): IEnumFormatEtc; |
| begin |
| if (dwDirection = DATADIR_GET) then |
| Result := TEnumFormatEtc.Create(pFormatList(@FDataFormats), FDataFormatsCount, 0) |
| else |
| result := nil; |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TDropSource.AddFormatEtc(cfFmt: TClipFormat; |
| pt: PDVTargetDevice; dwAsp, lInd, tym: longint); |
| begin |
| if fDataFormatsCount = MAXFORMATS then exit; |
| FDataFormats[fDataFormatsCount].cfFormat := cfFmt; |
| FDataFormats[fDataFormatsCount].ptd := pt; |
| FDataFormats[fDataFormatsCount].dwAspect := dwAsp; |
| FDataFormats[fDataFormatsCount].lIndex := lInd; |
| FDataFormats[fDataFormatsCount].tymed := tym; |
| inc(FDataFormatsCount); |
| end; |
| // ----------------------------------------------------------------------------- |
| // ----------------------------------------------------------------------------- |
| function TDropSource.HasFormat(const FormatEtc: TFormatEtc): boolean; |
| begin |
| Result := True; |
| { TODO -oanme -cStopShip : TDropSource.HasFormat needs implementation } |
| end; |
| initialization |
| OleInitialize(NIL); |
| ShGetMalloc(ShellMalloc); |
| finalization |
| ShellMalloc := nil; |
| OleUninitialize; |
| end. |
| /trunk/VCL_DRAGDROP/DropTarget.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DropTarget.pas |
|---|
| 0,0 → 1,1605 |
| unit DropTarget; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite |
| // Module: DropTarget |
| // Description: Implements the drop target base classes which allows your |
| // application to accept data dropped on it from other |
| // applications. |
| // Version: 4.0 |
| // Date: 18-MAY-2001 |
| // Target: Win32, Delphi 5-6 |
| // Authors: Anders Melander, anders@melander.dk, http://www.melander.dk |
| // Copyright © 1997-2001 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| // General changes: |
| // - Some component glyphs has changed. |
| // - New components: |
| // * TDropMetaFileTarget |
| // * TDropImageTarget |
| // * TDropSuperTarget |
| // * Replaced all use of KeysToShiftState with KeysToShiftStatePlus for |
| // correct mapping of Alt key. |
| // TCustomDropTarget changes: |
| // - New protected method SetDataObject. |
| // Provides write access to DataObject property for use in descendant classes. |
| // - New protected methods: GetPreferredDropEffect and SetPerformedDropEffect. |
| // - New protected method DoUnregister handles unregistration of all or |
| // individual targets. |
| // - Unregister method has been overloaded to handle multiple drop targets |
| // (Delphi 4 and later only). |
| // - All private methods has been made protected. |
| // - New public methods: FindTarget and FindNearestTarget. |
| // For use with multiple drop targets. |
| // - New published property MultiTarget enables multiple drop targets. |
| // - New public property Targets for support of multiple drop targets. |
| // - Visibility of Target property has changed from public to published and |
| // has been made writable. |
| // - PasteFromClipboard method now handles all formats via DoGetData. |
| // - Now "handles" situations where the target window handle is recreated. |
| // - Implemented TCustomDropTarget.Assign to assign from TClipboard and any object |
| // which implements IDataObject. |
| // - Added support for optimized moves and delete-on-paste with new |
| // OptimizedMove property. |
| // - Fixed inconsistency between GetValidDropEffect and standard IDropTarget |
| // behaviour. |
| // - The HasValidFormats method has been made public and now accepts an |
| // IDataObject as a parameter. |
| // - The OnGetDropEffect Effect parameter is now initialized to the drop |
| // source's allowed drop effect mask prior to entry. |
| // - Added published AutoScroll property and OnScroll even´t and public |
| // NoScrollZone property. |
| // Auto scroling can now be completely customized via the OnDragEnter, |
| // OnDragOver OnGetDropEffect and OnScroll events and the above properties. |
| // - Added support for IDropTargetHelper interface. |
| // - Added support for IAsyncOperation interface. |
| // - New OnStartAsyncTransfer and OnEndAsyncTransfer events. |
| // |
| // TDropDummy changes: |
| // - Bug in HasValidFormats fixed. Spotted by David Polberger. |
| // Return value changed from True to False. |
| // |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DragDrop, |
| Windows, ActiveX, Classes, Controls, CommCtrl, ExtCtrls, Forms; |
| {$include DragDrop.inc} |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TControlList |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // List of TWinControl objects. |
| // Used for the TCustomDropTarget.Targets property. |
| //////////////////////////////////////////////////////////////////////////////// |
| type |
| TControlList = class(TObject) |
| private |
| FList: TList; |
| function GetControl(AIndex: integer): TWinControl; |
| function GetCount: integer; |
| protected |
| function Add(AControl: TWinControl): integer; |
| procedure Insert(Index: Integer; AControl: TWinControl); |
| procedure Remove(AControl: TWinControl); |
| procedure Delete(AIndex: integer); |
| public |
| constructor Create; |
| destructor Destroy; override; |
| function IndexOf(AControl: TWinControl): integer; |
| property Count: integer read GetCount; |
| property Controls[AIndex: integer]: TWinControl read GetControl; default; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomDropTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Top level abstract base class for all drop target classes. |
| // Implements the IDropTarget and IDataObject interfaces. |
| // Do not derive from TCustomDropTarget! Instead derive from TCustomDropTarget. |
| // TCustomDropTarget will be replaced by/renamed to TCustomDropTarget in a future |
| // version. |
| //////////////////////////////////////////////////////////////////////////////// |
| type |
| TScrolDirection = (sdUp, sdDown, sdLeft, sdRight); |
| TScrolDirections = set of TScrolDirection; |
| TDropTargetScrollEvent = procedure(Sender: TObject; Point: TPoint; |
| var Scroll: TScrolDirections; var Interval: integer) of object; |
| TScrollBars = set of TScrollBarKind; |
| TDropTargetEvent = procedure(Sender: TObject; ShiftState: TShiftState; |
| APoint: TPoint; var Effect: Longint) of object; |
| TCustomDropTarget = class(TDragDropComponent, IDropTarget) |
| private |
| FDataObject : IDataObject; |
| FDragTypes : TDragTypes; |
| FGetDataOnEnter : boolean; |
| FOnEnter : TDropTargetEvent; |
| FOnDragOver : TDropTargetEvent; |
| FOnLeave : TNotifyEvent; |
| FOnDrop : TDropTargetEvent; |
| FOnGetDropEffect : TDropTargetEvent; |
| FOnScroll : TDropTargetScrollEvent; |
| FTargets : TControlList; |
| FMultiTarget : boolean; |
| FOptimizedMove : boolean; |
| FTarget : TWinControl; |
| FImages : TImageList; |
| FDragImageHandle : HImageList; |
| FShowImage : boolean; |
| FImageHotSpot : TPoint; |
| FDropTargetHelper : IDropTargetHelper; |
| // FLastPoint points to where DragImage was last painted (used internally) |
| FLastPoint : TPoint; |
| // Auto scrolling enables scrolling of target window during drags and |
| // paints any drag image 'cleanly'. |
| FScrollBars : TScrollBars; |
| FScrollTimer : TTimer; |
| FAutoScroll : boolean; |
| FNoScrollZone : TRect; |
| FIsAsync : boolean; |
| FOnEndAsyncTransfer : TNotifyEvent; |
| FOnStartAsyncTransfer: TNotifyEvent; |
| FAllowAsync : boolean; |
| protected |
| // IDropTarget implementation |
| function DragEnter(const DataObj: IDataObject; grfKeyState: Longint; |
| pt: TPoint; var dwEffect: Longint): HRESULT; stdcall; |
| function DragOver(grfKeyState: Longint; pt: TPoint; |
| var dwEffect: Longint): HRESULT; stdcall; |
| function DragLeave: HRESULT; stdcall; |
| function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; |
| var dwEffect: Longint): HRESULT; stdcall; |
| procedure DoEnter(ShiftState: TShiftState; Point: TPoint; var Effect: Longint); virtual; |
| procedure DoDragOver(ShiftState: TShiftState; Point: TPoint; var Effect: Longint); virtual; |
| procedure DoDrop(ShiftState: TShiftState; Point: TPoint; var Effect: Longint); virtual; |
| procedure DoLeave; virtual; |
| procedure DoOnPaste(var Effect: Integer); virtual; |
| procedure DoScroll(Point: TPoint; var Scroll: TScrolDirections; |
| var Interval: integer); virtual; |
| function GetData(Effect: longInt): boolean; virtual; |
| function DoGetData: boolean; virtual; abstract; |
| procedure ClearData; virtual; abstract; |
| function GetValidDropEffect(ShiftState: TShiftState; pt: TPoint; |
| dwEffect: LongInt): LongInt; virtual; // V4: Improved |
| function GetPreferredDropEffect: LongInt; virtual; // V4: New |
| function SetPerformedDropEffect(Effect: LongInt): boolean; virtual; // V4: New |
| function SetPasteSucceded(Effect: LongInt): boolean; virtual; // V4: New |
| procedure DoUnregister(ATarget: TWinControl); // V4: New |
| procedure Notification(AComponent: TComponent; Operation: TOperation); override; |
| function GetTarget: TWinControl; |
| procedure SetTarget(const Value: TWinControl); |
| procedure DoAutoScroll(Sender: TObject); // V4: Renamed from DoTargetScroll. |
| procedure SetShowImage(Show: boolean); |
| procedure SetDataObject(Value: IDataObject); // V4: New |
| procedure DoEndAsyncTransfer(Sender: TObject); |
| property DropTargetHelper: IDropTargetHelper read FDropTargetHelper; |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; override; |
| procedure Register(ATarget: TWinControl); |
| {$ifdef VER12_PLUS} |
| procedure Unregister(ATarget: TWinControl = nil); // V4: New |
| {$else} |
| procedure Unregister; |
| {$endif} |
| function FindTarget(p: TPoint): TWinControl; virtual; // V4: New |
| function FindNearestTarget(p: TPoint): TWinControl; // V4: New |
| procedure Assign(Source: TPersistent); override; // V4: New |
| function HasValidFormats(ADataObject: IDataObject): boolean; virtual; abstract; // V4: Improved |
| function PasteFromClipboard: longint; virtual; // V4: Improved |
| property DataObject: IDataObject read FDataObject; |
| property Targets: TControlList read FTargets; // V4: New |
| property NoScrollZone: TRect read FNoScrollZone write FNoScrollZone; // V4: New |
| property AsyncTransfer: boolean read FIsAsync; |
| published |
| property Dragtypes: TDragTypes read FDragTypes write FDragTypes; |
| property GetDataOnEnter: Boolean read FGetDataOnEnter write FGetDataOnEnter; |
| // Events... |
| property OnEnter: TDropTargetEvent read FOnEnter write FOnEnter; |
| property OnDragOver: TDropTargetEvent read FOnDragOver write FOnDragOver; |
| property OnLeave: TNotifyEvent read FOnLeave write FOnLeave; |
| property OnDrop: TDropTargetEvent read FOnDrop write FOnDrop; |
| property OnGetDropEffect: TDropTargetEvent read FOnGetDropEffect |
| write FOnGetDropEffect; // V4: Improved |
| property OnScroll: TDropTargetScrollEvent read FOnScroll write FOnScroll; // V4: New |
| property OnStartAsyncTransfer: TNotifyEvent read FOnStartAsyncTransfer |
| write FOnStartAsyncTransfer; |
| property OnEndAsyncTransfer: TNotifyEvent read FOnEndAsyncTransfer |
| write FOnEndAsyncTransfer; |
| // Drag Images... |
| property ShowImage: boolean read FShowImage write SetShowImage; |
| // Target |
| property Target: TWinControl read GetTarget write SetTarget; // V4: Improved |
| property MultiTarget: boolean read FMultiTarget write FMultiTarget default False; // V4: New |
| // Auto scroll |
| property AutoScroll: boolean read FAutoScroll write FAutoScroll default True; // V4: New |
| // Misc |
| property OptimizedMove: boolean read FOptimizedMove write FOptimizedMove default False; // V4: New |
| // Async transfer... |
| property AllowAsyncTransfer: boolean read FAllowAsync write FAllowAsync; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Deprecated base class for all drop target components. |
| // Replaced by the TCustomDropTarget class. |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropTarget = class(TCustomDropTarget) |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropDummy |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // The sole purpose of this component is to enable drag images to be displayed |
| // over the registered TWinControl(s). The component does not accept any drops. |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropDummy = class(TCustomDropTarget) |
| protected |
| procedure ClearData; override; |
| function DoGetData: boolean; override; |
| public |
| function HasValidFormats(ADataObject: IDataObject): boolean; override; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomDropMultiTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Drop target base class which can accept multiple formats. |
| //////////////////////////////////////////////////////////////////////////////// |
| TAcceptFormatEvent = procedure(Sender: TObject; |
| const DataFormat: TCustomDataFormat; var Accept: boolean) of object; |
| TCustomDropMultiTarget = class(TCustomDropTarget) |
| private |
| FOnAcceptFormat: TAcceptFormatEvent; |
| protected |
| procedure ClearData; override; |
| function DoGetData: boolean; override; |
| procedure DoAcceptFormat(const DataFormat: TCustomDataFormat; |
| var Accept: boolean); virtual; |
| property OnAcceptFormat: TAcceptFormatEvent read FOnAcceptFormat |
| write FOnAcceptFormat; |
| public |
| constructor Create(AOwner: TComponent); override; |
| destructor Destroy; override; |
| function HasValidFormats(ADataObject: IDataObject): boolean; override; |
| property DataFormats; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropEmptyTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| // Do-nothing target for use with TDataFormatAdapter and such |
| //////////////////////////////////////////////////////////////////////////////// |
| TDropEmptyTarget = class(TCustomDropMultiTarget); |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Misc. |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| (******************************************************************************* |
| ** |
| ** IMPLEMENTATION |
| ** |
| *******************************************************************************) |
| implementation |
| uses |
| DragDropFormats, |
| ComObj, |
| SysUtils, |
| Graphics, |
| Messages, |
| ShlObj, |
| ClipBrd, |
| ComCtrls; |
| resourcestring |
| sAsyncBusy = 'Can''t clear data while async data transfer is in progress'; |
| // sRegisterFailed = 'Failed to register %s as a drop target'; |
| // sUnregisterActiveTarget = 'Can''t unregister target while drag operation is in progress'; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Component registration |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| procedure Register; |
| begin |
| RegisterComponents(DragDropComponentPalettePage, [TDropEmptyTarget, TDropDummy]); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // Misc. |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TControlList |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TControlList.Create; |
| begin |
| inherited Create; |
| FList := TList.Create; |
| end; |
| destructor TControlList.Destroy; |
| begin |
| FList.Free; |
| inherited Destroy; |
| end; |
| function TControlList.Add(AControl: TWinControl): integer; |
| begin |
| Result := FList.Add(AControl); |
| end; |
| procedure TControlList.Insert(Index: Integer; AControl: TWinControl); |
| begin |
| FList.Insert(Index, AControl); |
| end; |
| procedure TControlList.Delete(AIndex: integer); |
| begin |
| FList.Delete(AIndex); |
| end; |
| function TControlList.IndexOf(AControl: TWinControl): integer; |
| begin |
| Result := FList.IndexOf(AControl); |
| end; |
| function TControlList.GetControl(AIndex: integer): TWinControl; |
| begin |
| Result := TWinControl(FList[AIndex]); |
| end; |
| function TControlList.GetCount: integer; |
| begin |
| Result := FList.Count; |
| end; |
| procedure TControlList.Remove(AControl: TWinControl); |
| begin |
| FList.Remove(AControl); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomDropTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TCustomDropTarget.Create(AOwner: TComponent); |
| var |
| bm : TBitmap; |
| begin |
| inherited Create(AOwner); |
| FScrollTimer := TTimer.Create(Self); |
| FScrollTimer.Enabled := False; |
| FScrollTimer.OnTimer := DoAutoScroll; |
| // Note: Normally we would call _AddRef or coLockObjectExternal(Self) here to |
| // make sure that the component wasn't deleted prematurely (e.g. after a call |
| // to RegisterDragDrop), but since our ancestor class TInterfacedComponent |
| // disables reference counting, we do not need to do so. |
| FGetDataOnEnter := False; |
| FTargets := TControlList.Create; |
| FImages := TImageList.Create(Self); |
| // Create a blank image for FImages which we will use to hide any cursor |
| // 'embedded' in a drag image. |
| // This avoids the possibility of two cursors showing. |
| bm := TBitmap.Create; |
| try |
| bm.Height := 32; |
| bm.Width := 32; |
| bm.Canvas.Brush.Color := clWindow; |
| bm.Canvas.FillRect(bm.Canvas.ClipRect); |
| FImages.AddMasked(bm, clWindow); |
| finally |
| bm.Free; |
| end; |
| FDataObject := nil; |
| ShowImage := True; |
| FMultiTarget := False; |
| FOptimizedMove := False; |
| FAutoScroll := True; |
| end; |
| destructor TCustomDropTarget.Destroy; |
| begin |
| FDataObject := nil; |
| FDropTargetHelper := nil; |
| Unregister; |
| FImages.Free; |
| FScrollTimer.Free; |
| FTargets.Free; |
| inherited Destroy; |
| end; |
| // TDummyWinControl is declared just to expose the protected property - Font - |
| // which is used to calculate the 'scroll margin' for the target window. |
| type |
| TDummyWinControl = Class(TWinControl); |
| function TCustomDropTarget.DragEnter(const dataObj: IDataObject; grfKeyState: Longint; |
| pt: TPoint; var dwEffect: Longint): HRESULT; |
| var |
| ShiftState : TShiftState; |
| TargetStyles : longint; |
| begin |
| ClearData; |
| FDataObject := dataObj; |
| Result := S_OK; |
| // Find the target control. |
| FTarget := FindTarget(pt); |
| (* |
| ** If no target control has been registered we disable all features which |
| ** depends on the existence of a drop target (e.g. drag images and auto |
| ** scroll). Presently, this situation can only arise if the drop target is |
| ** being used as a drop handler (TDrophandler component). |
| ** Note also that if no target control exists, the mouse coordinates are |
| ** relative to the screen, not the control as is normally the case. |
| *) |
| if (FTarget = nil) then |
| begin |
| ShowImage := False; |
| AutoScroll := False; |
| end else |
| begin |
| pt := FTarget.ScreenToClient(pt); |
| FLastPoint := pt; |
| end; |
| (* |
| ** Refuse the drag if we can't handle any of the data formats offered by |
| ** the drop source. We must return S_OK here in order for the drop to continue |
| ** to generate DragOver events for this drop target (needed for drag images). |
| *) |
| if HasValidFormats(FDataObject) then |
| begin |
| FScrollBars := []; |
| if (AutoScroll) then |
| begin |
| // Determine if the target control has scroll bars (and which). |
| TargetStyles := GetWindowLong(FTarget.Handle, GWL_STYLE); |
| if (TargetStyles and WS_HSCROLL <> 0) then |
| include(FScrollBars, sbHorizontal); |
| if (TargetStyles and WS_VSCROLL <> 0) then |
| include(FScrollBars, sbVertical); |
| // The Windows UI guidelines recommends that the scroll margin be based on |
| // the width/height of the scroll bars: |
| // From "The Windows Interface Guidelines for Software Design", page 82: |
| // "Use twice the width of a vertical scroll bar or height of a |
| // horizontal scroll bar to determine the width of the hot zone." |
| // Previous versions of these components used the height of the current |
| // target control font as the scroll margin. Yet another approach would be |
| // to use the DragDropScrollInset constant. |
| if (FScrollBars <> []) then |
| begin |
| FNoScrollZone := FTarget.ClientRect; |
| if (sbVertical in FScrollBars) then |
| InflateRect(FNoScrollZone, 0, -GetSystemMetrics(SM_CYHSCROLL)); |
| // InflateRect(FNoScrollZone, 0, -abs(TDummyWinControl(FTarget).Font.Height)); |
| if (sbHorizontal in FScrollBars) then |
| InflateRect(FNoScrollZone, -GetSystemMetrics(SM_CXHSCROLL), 0); |
| // InflateRect(FNoScrollZone, -abs(TDummyWinControl(FTarget).Font.Height), 0); |
| end; |
| end; |
| // It's generally more efficient to get data only if and when a drop occurs |
| // rather than on entering a potential target window. |
| // However - sometimes there is a good reason to get it here. |
| if FGetDataOnEnter then |
| if (not GetData(dwEffect)) then |
| begin |
| FDataObject := nil; |
| dwEffect := DROPEFFECT_NONE; |
| Result := DV_E_CLIPFORMAT; |
| exit; |
| end; |
| ShiftState := KeysToShiftStatePlus(grfKeyState); |
| // Create a default drop effect based on the shift state and allowed |
| // drop effects (or an OnGetDropEffect event if implemented). |
| dwEffect := GetValidDropEffect(ShiftState, Pt, dwEffect); |
| // Generate an OnEnter event |
| DoEnter(ShiftState, pt, dwEffect); |
| // If IDropTarget.DragEnter returns with dwEffect set to DROPEFFECT_NONE it |
| // means that the drop has been rejected and IDropTarget.DragOver should |
| // not be called (according to MSDN). Unfortunately IDropTarget.DragOver is |
| // called regardless of the value of dwEffect. We work around this problem |
| // (bug?) by setting FDataObject to nil and thus internally rejecting the |
| // drop in TCustomDropTarget.DragOver. |
| if (dwEffect = DROPEFFECT_NONE) then |
| FDataObject := nil; |
| end else |
| begin |
| FDataObject := nil; |
| dwEffect := DROPEFFECT_NONE; |
| end; |
| // Display drag image. |
| // Note: This was previously done prior to caling GetValidDropEffect and |
| // DoEnter. The SDK documentation states that IDropTargetHelper.DragEnter |
| // should be called last in IDropTarget.DragEnter (presumably after dwEffect |
| // has been modified), but Microsoft's own demo application calls it as the |
| // very first thing (same for all other IDropTargetHelper methods). |
| if ShowImage then |
| begin |
| // Attempt to create Drag Drop helper object. |
| // At present this is only supported on Windows 2000. If the object can't be |
| // created, we fall back to the old image list based method (which only |
| // works on Win9x). |
| CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, |
| IDropTargetHelper, FDropTargetHelper); |
| if (FDropTargetHelper <> nil) then |
| begin |
| // If the call to DragEnter fails (which it will do if the drop source |
| // doesn't support IDropSourceHelper or hasn't specified a drag image), |
| // we release the drop target helper and fall back to imagelist based |
| // drag images. |
| if (DropTargetHelper.DragEnter(FTarget.Handle, DataObj, pt, dwEffect) <> S_OK) then |
| FDropTargetHelper := nil; |
| end; |
| if (FDropTargetHelper = nil) then |
| begin |
| FDragImageHandle := ImageList_GetDragImage(nil, @FImageHotSpot); |
| if (FDragImageHandle <> 0) then |
| begin |
| // Currently we will just replace any 'embedded' cursor with our |
| // blank (transparent) image otherwise we sometimes get 2 cursors ... |
| ImageList_SetDragCursorImage(FImages.Handle, 0, FImageHotSpot.x, FImageHotSpot.y); |
| with ClientPtToWindowPt(FTarget.Handle, pt) do |
| ImageList_DragEnter(FTarget.handle, x, y); |
| end; |
| end; |
| end else |
| FDragImageHandle := 0; |
| end; |
| procedure TCustomDropTarget.DoEnter(ShiftState: TShiftState; Point: TPoint; var Effect: Longint); |
| begin |
| if Assigned(FOnEnter) then |
| FOnEnter(Self, ShiftState, Point, Effect); |
| end; |
| function TCustomDropTarget.DragOver(grfKeyState: Longint; pt: TPoint; |
| var dwEffect: Longint): HResult; |
| var |
| ShiftState: TShiftState; |
| IsScrolling: boolean; |
| begin |
| // Refuse drop if we dermined in DragEnter that a drop weren't possible, |
| // but still handle drag images provided we have a valid target. |
| if (FTarget = nil) then |
| begin |
| dwEffect := DROPEFFECT_NONE; |
| Result := E_UNEXPECTED; |
| exit; |
| end; |
| pt := FTarget.ScreenToClient(pt); |
| if (FDataObject <> nil) then |
| begin |
| ShiftState := KeysToShiftStatePlus(grfKeyState); |
| // Create a default drop effect based on the shift state and allowed |
| // drop effects (or an OnGetDropEffect event if implemented). |
| dwEffect := GetValidDropEffect(ShiftState, pt, dwEffect); |
| // Generate an OnDragOver event |
| DoDragOver(ShiftState, pt, dwEffect); |
| // Note: Auto scroll is detected by the GetValidDropEffect method, but can |
| // also be started by the user via the OnDragOver or OnGetDropEffect events. |
| // Auto scroll is initiated by specifying the DROPEFFECT_SCROLL value as |
| // part of the drop effect. |
| // Start the auto scroll timer if auto scroll were requested. Do *not* rely |
| // on any other mechanisms to detect auto scroll since the user can only |
| // specify auto scroll with the DROPEFFECT_SCROLL value. |
| IsScrolling := (dwEffect and DROPEFFECT_SCROLL <> 0); |
| if (IsScrolling) and (not FScrollTimer.Enabled) then |
| begin |
| FScrollTimer.Interval := DragDropScrollDelay; // hardcoded to 100 in previous versions. |
| FScrollTimer.Enabled := True; |
| end; |
| Result := S_OK; |
| end else |
| begin |
| // Even though this isn't an error condition per se, we must return |
| // an error code (e.g. E_UNEXPECTED) in order for the cursor to change |
| // to DROPEFFECT_NONE. |
| IsScrolling := False; |
| Result := DV_E_CLIPFORMAT; |
| end; |
| // Move drag image |
| if (DropTargetHelper <> nil) then |
| begin |
| OleCheck(DropTargetHelper.DragOver(pt, dwEffect)); |
| end else |
| if (FDragImageHandle <> 0) then |
| begin |
| if (not IsScrolling) and ((FLastPoint.x <> pt.x) or (FLastPoint.y <> pt.y)) then |
| with ClientPtToWindowPt(FTarget.Handle, pt) do |
| ImageList_DragMove(x, y); |
| end; |
| FLastPoint := pt; |
| end; |
| procedure TCustomDropTarget.DoDragOver(ShiftState: TShiftState; Point: TPoint; var Effect: Longint); |
| begin |
| if Assigned(FOnDragOver) then |
| FOnDragOver(Self, ShiftState, Point, Effect); |
| end; |
| function TCustomDropTarget.DragLeave: HResult; |
| begin |
| ClearData; |
| FScrollTimer.Enabled := False; |
| FDataObject := nil; |
| if (DropTargetHelper <> nil) then |
| begin |
| DropTargetHelper.DragLeave; |
| end else |
| if (FDragImageHandle <> 0) then |
| ImageList_DragLeave(FTarget.Handle); |
| // Generate an OnLeave event. |
| // Protect resources against exceptions in event handler. |
| try |
| DoLeave; |
| finally |
| FTarget := nil; |
| FDropTargetHelper := nil; |
| end; |
| Result := S_OK; |
| end; |
| procedure TCustomDropTarget.DoLeave; |
| begin |
| if Assigned(FOnLeave) then |
| FOnLeave(Self); |
| end; |
| function TCustomDropTarget.Drop(const dataObj: IDataObject; grfKeyState: Longint; |
| pt: TPoint; var dwEffect: Longint): HResult; |
| var |
| ShiftState: TShiftState; |
| ClientPt: TPoint; |
| begin |
| FScrollTimer.Enabled := False; |
| // Protect resources against exceptions in OnDrop event handler. |
| try |
| // Refuse drop if we have lost the data object somehow. |
| // This can happen if the drop is rejected in one of the other IDropTarget |
| // methods (e.g. DragOver). |
| if (FDataObject = nil) then |
| begin |
| dwEffect := DROPEFFECT_NONE; |
| Result := E_UNEXPECTED; |
| end else |
| begin |
| ShiftState := KeysToShiftStatePlus(grfKeyState); |
| // Create a default drop effect based on the shift state and allowed |
| // drop effects (or an OnGetDropEffect event if implemented). |
| if (FTarget <> nil) then |
| ClientPt := FTarget.ScreenToClient(pt) |
| else |
| ClientPt := pt; |
| dwEffect := GetValidDropEffect(ShiftState, ClientPt, dwEffect); |
| // Get data from source and generate an OnDrop event unless we failed to |
| // get data. |
| if (FGetDataOnEnter) or (GetData(dwEffect)) then |
| DoDrop(ShiftState, ClientPt, dwEffect) |
| else |
| dwEffect := DROPEFFECT_NONE; |
| Result := S_OK; |
| end; |
| if (DropTargetHelper <> nil) then |
| begin |
| DropTargetHelper.Drop(DataObj, pt, dwEffect); |
| end else |
| if (FDragImageHandle <> 0) and (FTarget <> nil) then |
| ImageList_DragLeave(FTarget.Handle); |
| finally |
| // clean up! |
| ClearData; |
| FDataObject := nil; |
| FDropTargetHelper := nil; |
| FTarget := nil; |
| end; |
| end; |
| procedure TCustomDropTarget.DoDrop(ShiftState: TShiftState; Point: TPoint; var Effect: Longint); |
| begin |
| if Assigned(FOnDrop) then |
| FOnDrop(Self, ShiftState, Point, Effect); |
| (* |
| Optimized move (from MSDN): |
| Scenario: A file is moved from the file system to a namespace extension using |
| an optimized move. |
| In a conventional move operation, the target makes a copy of the data and the |
| source deletes the original. This procedure can be inefficient because it |
| requires two copies of the data. With large objects such as databases, a |
| conventional move operation might not even be practical. |
| With an optimized move, the target uses its understanding of how the data is |
| stored to handle the entire move operation. There is never a second copy of |
| the data, and there is no need for the source to delete the original data. |
| Shell data is well suited to optimized moves because the target can handle the |
| entire operation using the shell API. A typical example is moving files. Once |
| the target has the path of a file to be moved, it can use SHFileOperation to |
| move it. There is no need for the source to delete the original file. |
| Note The shell normally uses an optimized move to move files. To handle shell |
| data transfer properly, your application must be capable of detecting and |
| handling an optimized move. |
| Optimized moves are handled in the following way: |
| 1) The source calls DoDragDrop with the dwEffect parameter set to |
| DROPEFFECT_MOVE to indicate that the source objects can be moved. |
| 2) The target receives the DROPEFFECT_MOVE value through one of its |
| IDropTarget methods, indicating that a move is allowed. |
| 3) The target either copies the object (unoptimized move) or moves the object |
| (optimized move). |
| 4) The target then tells the source whether it needs to delete the original |
| data. |
| An optimized move is the default operation, with the data deleted by the |
| target. To inform the source that an optimized move was performed: |
| - The target sets the pdwEffect value it received through its |
| IDropTarget::Drop method to some value other than DROPEFFECT_MOVE. It is |
| typically set to either DROPEFFECT_NONE or DROPEFFECT_COPY. The value |
| will be returned to the source by DoDragDrop. |
| - The target also calls the data object's IDataObject::SetData method and |
| passes it a CFSTR_PERFORMEDDROPEFFECT format identifier set to |
| DROPEFFECT_NONE. This method call is necessary because some drop targets |
| might not set the pdwEffect parameter of DoDragDrop properly. The |
| CFSTR_PERFORMEDDROPEFFECT format is the reliable way to indicate that an |
| optimized move has taken place. |
| If the target did an unoptimized move, the data must be deleted by the |
| source. To inform the source that an unoptimized move was performed: |
| - The target sets the pdwEffect value it received through its |
| IDropTarget::Drop method to DROPEFFECT_MOVE. The value will be returned |
| to the source by DoDragDrop. |
| - The target also calls the data object's IDataObject::SetData method and |
| passes it a CFSTR_PERFORMEDDROPEFFECT format identifier set to |
| DROPEFFECT_MOVE. This method call is necessary because some drop targets |
| might not set the pdwEffect parameter of DoDragDrop properly. The |
| CFSTR_PERFORMEDDROPEFFECT format is the reliable way to indicate that an |
| unoptimized move has taken place. |
| 5) The source inspects the two values that can be returned by the target. If |
| both are set to DROPEFFECT_MOVE, it completes the unoptimized move by |
| deleting the original data. Otherwise, the target did an optimized move and |
| the original data has been deleted. |
| *) |
| // TODO : Why isn't this code in the Drop method? |
| // Report performed drop effect back to data originator. |
| if (Effect <> DROPEFFECT_NONE) then |
| begin |
| // If the transfer was an optimized move operation (target deletes data), |
| // we convert the move operation to a copy operation to prevent that the |
| // source deletes the data. |
| if (FOptimizedMove) and (Effect = DROPEFFECT_MOVE) then |
| Effect := DROPEFFECT_COPY; |
| SetPerformedDropEffect(Effect); |
| end; |
| end; |
| type |
| TDropTargetTransferThread = class(TThread) |
| private |
| FCustomDropTarget: TCustomDropTarget; |
| FDataObject: IDataObject; |
| FEffect: Longint; |
| FMarshalStream: pointer; |
| protected |
| procedure Execute; override; |
| property MarshalStream: pointer read FMarshalStream write FMarshalStream; |
| public |
| constructor Create(ACustomDropTarget: TCustomDropTarget; |
| const ADataObject: IDataObject; AEffect: Longint); |
| property CustomDropTarget: TCustomDropTarget read FCustomDropTarget; |
| property DataObject: IDataObject read FDataObject; |
| property Effect: Longint read FEffect; |
| end; |
| constructor TDropTargetTransferThread.Create(ACustomDropTarget: TCustomDropTarget; |
| const ADataObject: IDataObject; AEffect: longInt); |
| begin |
| inherited Create(True); |
| FreeOnTerminate := True; |
| FCustomDropTarget := ACustomDropTarget; |
| OnTerminate := FCustomDropTarget.DoEndAsyncTransfer; |
| FEffect := AEffect; |
| OleCheck(CoMarshalInterThreadInterfaceInStream(IDataObject, ADataObject, |
| IStream(FMarshalStream))); |
| end; |
| procedure TDropTargetTransferThread.Execute; |
| var |
| Res: HResult; |
| begin |
| CoInitialize(nil); |
| try |
| try |
| OleCheck(CoGetInterfaceAndReleaseStream(IStream(MarshalStream), |
| IDataObject, FDataObject)); |
| MarshalStream := nil; |
| CustomDropTarget.FDataObject := DataObject; |
| CustomDropTarget.DoGetData; |
| Res := S_OK; |
| except |
| Res := E_UNEXPECTED; |
| end; |
| (FDataObject as IAsyncOperation).EndOperation(Res, nil, Effect); |
| finally |
| FDataObject := nil; |
| CoUninitialize; |
| end; |
| end; |
| procedure TCustomDropTarget.DoEndAsyncTransfer(Sender: TObject); |
| begin |
| // Reset async transfer flag once transfer completes and... |
| FIsAsync := False; |
| // ...Fire event. |
| if Assigned(FOnEndAsyncTransfer) then |
| FOnEndAsyncTransfer(Self); |
| end; |
| function TCustomDropTarget.GetData(Effect: longInt): boolean; |
| var |
| DoAsync: LongBool; |
| AsyncOperation: IAsyncOperation; |
| // h: HResult; |
| begin |
| ClearData; |
| // Determine if drop source supports and has enabled asynchronous data |
| // transfer. |
| (* |
| h := DataObject.QueryInterface(IAsyncOperation, AsyncOperation); |
| h := DataObject.QueryInterface(IDropSource, AsyncOperation); |
| OutputDebugString(PChar(SysErrorMessage(h))); |
| *) |
| if not(AllowAsyncTransfer and |
| Succeeded(DataObject.QueryInterface(IAsyncOperation, AsyncOperation)) and |
| Succeeded(AsyncOperation.GetAsyncMode(DoAsync))) then |
| DoAsync := False; |
| // Start an async data transfer... |
| if (DoAsync) then |
| begin |
| // Fire event. |
| if Assigned(FOnStartAsyncTransfer) then |
| FOnStartAsyncTransfer(Self); |
| FIsAsync := True; |
| // Notify drop source that an async data transfer is starting. |
| AsyncOperation.StartOperation(nil); |
| // Create the data transfer thread and launch it. |
| with TDropTargetTransferThread.Create(Self, DataObject, Effect) do |
| Resume; |
| Result := True; |
| end else |
| Result := DoGetData; |
| end; |
| procedure TCustomDropTarget.Notification(AComponent: TComponent; |
| Operation: TOperation); |
| begin |
| inherited Notification(AComponent, Operation); |
| if (Operation = opRemove) and (AComponent is TWinControl) then |
| begin |
| if (csDesigning in ComponentState) and (AComponent = FTarget) then |
| FTarget := nil; |
| if (FTargets.IndexOf(TWinControl(AComponent)) <> -1) then |
| DoUnregister(TWinControl(AComponent)); |
| end; |
| end; |
| type |
| TWinControlProxy = class(TWinControl) |
| protected |
| procedure DestroyWnd; override; |
| procedure CreateWnd; override; |
| end; |
| procedure TWinControlProxy.CreateWnd; |
| begin |
| inherited CreateWnd; |
| OleCheck(RegisterDragDrop(Parent.Handle, TCustomDropTarget(Owner))); |
| Visible := False; |
| end; |
| procedure TWinControlProxy.DestroyWnd; |
| begin |
| if (Parent.HandleAllocated) then |
| RevokeDragDrop(Parent.Handle); |
| // Control must be visible in order to guarantee that CreateWnd is called when |
| // parent control recreates window handle. |
| Visible := True; |
| inherited DestroyWnd; |
| end; |
| procedure TCustomDropTarget.Register(ATarget: TWinControl); |
| function Contains(Parent, Child: TWinControl): boolean; |
| var |
| i: integer; |
| begin |
| if (Child.Parent <> Parent) then |
| begin |
| Result := False; |
| for i := 0 to Parent.ControlCount-1 do |
| if (Parent.Controls[i] is TWinControl) and |
| Contains(TWinControl(Parent.Controls[i]), Child) then |
| begin |
| Result := True; |
| break; |
| end; |
| end else |
| Result := True; |
| end; |
| var |
| i: integer; |
| Inserted: boolean; |
| begin |
| // Don't register if the target is already registered. |
| // TODO -cImprovement : Maybe we should unregister and reregister the target if it has already been registered (in case the handle has changed)... |
| if (FTargets.IndexOf(ATarget) <> -1) then |
| exit; |
| // Unregister previous target unless MultiTarget is enabled (for backwards |
| // compatibility). |
| if (not FMultiTarget) and not(csLoading in ComponentState) then |
| Unregister; |
| if (ATarget = nil) then |
| exit; |
| // Insert the target in Z order, Topmost last. |
| // Note: The target is added to the target list even though the drop target |
| // registration may fail below. This is done because we would like |
| // the target to be unregistered (RevokeDragDrop) even if we failed to |
| // register it. |
| Inserted := False; |
| for i := FTargets.Count-1 downto 0 do |
| if Contains(FTargets[i], ATarget) then |
| begin |
| FTargets.Insert(i+1, ATarget); |
| Inserted := True; |
| break; |
| end; |
| if (not Inserted) then |
| begin |
| FTargets.Add(ATarget); |
| // ATarget.FreeNotification(Self); |
| end; |
| // If the target is a TRichEdit control, we disable the rich edit control's |
| // built-in drag/drop support. |
| if (ATarget is TCustomRichEdit) then |
| RevokeDragDrop(ATarget.Handle); |
| // Create a child control to monitor the target window handle. |
| // The child control will perform the drop target registration for us. |
| with TWinControlProxy.Create(Self) do |
| Parent := ATarget; |
| end; |
| {$ifdef VER12_PLUS} |
| procedure TCustomDropTarget.Unregister(ATarget: TWinControl); |
| begin |
| // Unregister a single targets (or all targets if ATarget is nil). |
| DoUnregister(ATarget); |
| end; |
| {$else} |
| procedure TCustomDropTarget.Unregister; |
| begin |
| // Unregister all targets (for backward compatibility). |
| DoUnregister(nil); |
| end; |
| {$endif} |
| procedure TCustomDropTarget.DoUnregister(ATarget: TWinControl); |
| var |
| i : integer; |
| begin |
| if (ATarget = nil) then |
| begin |
| for i := FTargets.Count-1 downto 0 do |
| DoUnregister(FTargets[i]); |
| exit; |
| end; |
| i := FTargets.IndexOf(ATarget); |
| if (i = -1) then |
| exit; |
| if (ATarget = FTarget) then |
| FTarget := nil; |
| // raise Exception.Create(sUnregisterActiveTarget); |
| FTargets.Delete(i); |
| (* Handled by proxy |
| if (ATarget.HandleAllocated) then |
| // Ignore failed unregistrations - nothing to do about it anyway |
| RevokeDragDrop(ATarget.Handle); |
| *) |
| // Delete target proxy. |
| // The target proxy willl unregister the drop target for us when it is |
| // destroyed. |
| for i := ATarget.ControlCount-1 downto 0 do |
| if (ATarget.Controls[i] is TWinControlProxy) and |
| (TWinControlProxy(ATarget.Controls[i]).Owner = Self) then |
| with TWinControlProxy(ATarget.Controls[i]) do |
| begin |
| Parent := nil; |
| Free; |
| break; |
| end; |
| end; |
| function TCustomDropTarget.FindTarget(p: TPoint): TWinControl; |
| (* |
| var |
| i: integer; |
| r: TRect; |
| Parent: TWinControl; |
| *) |
| begin |
| Result := FindVCLWindow(p); |
| while (Result <> nil) and (Targets.IndexOf(Result) = -1) do |
| begin |
| Result := Result.Parent; |
| end; |
| (* |
| // Search list in Z order. Top to bottom. |
| for i := Targets.Count-1 downto 0 do |
| begin |
| Result := Targets[i]; |
| // If the control or any of its parent aren't visible, we can't drop on it. |
| Parent := Result; |
| while (Parent <> nil) do |
| begin |
| if (not Parent.Showing) then |
| break; |
| Parent := Parent.Parent; |
| end; |
| if (Parent <> nil) then |
| continue; |
| GetWindowRect(Result.Handle, r); |
| if PtInRect(r, p) then |
| exit; |
| end; |
| Result := nil; |
| *) |
| end; |
| function TCustomDropTarget.FindNearestTarget(p: TPoint): TWinControl; |
| var |
| i : integer; |
| r : TRect; |
| pc : TPoint; |
| Control : TWinControl; |
| Dist , |
| BestDist : integer; |
| function Distance(r: TRect; p: TPoint): integer; |
| var |
| dx , |
| dy : integer; |
| begin |
| if (p.x < r.Left) then |
| dx := r.Left - p.x |
| else if (p.x > r.Right) then |
| dx := r.Right - p.x |
| else |
| dx := 0; |
| if (p.y < r.Top) then |
| dy := r.Top - p.y |
| else if (p.y > r.Bottom) then |
| dy := r.Bottom - p.y |
| else |
| dy := 0; |
| Result := dx*dx + dy*dy; |
| end; |
| begin |
| Result := nil; |
| BestDist := high(integer); |
| for i := 0 to Targets.Count-1 do |
| begin |
| Control := Targets[i]; |
| r := Control.ClientRect; |
| inc(r.Right); |
| inc(r.Bottom); |
| pc := Control.ScreenToClient(p); |
| if (PtInRect(r, p)) then |
| begin |
| Result := Control; |
| exit; |
| end; |
| Dist := Distance(r, pc); |
| if (Dist < BestDist) then |
| begin |
| Result := Control; |
| BestDist := Dist; |
| end; |
| end; |
| end; |
| function TCustomDropTarget.GetTarget: TWinControl; |
| begin |
| Result := FTarget; |
| if (Result = nil) and not(csDesigning in ComponentState) then |
| begin |
| if (FTargets.Count > 0) then |
| Result := TWinControl(FTargets[0]) |
| else |
| Result := nil; |
| end; |
| end; |
| procedure TCustomDropTarget.SetTarget(const Value: TWinControl); |
| begin |
| if (FTarget = Value) then |
| exit; |
| if (csDesigning in ComponentState) then |
| FTarget := Value |
| else |
| begin |
| // If MultiTarget isn't enabled, Register will automatically unregister do |
| // no need to do it here. |
| if (FMultiTarget) and not(csLoading in ComponentState) then |
| Unregister; |
| Register(Value); |
| end; |
| end; |
| procedure TCustomDropTarget.SetDataObject(Value: IDataObject); |
| begin |
| FDataObject := Value; |
| end; |
| procedure TCustomDropTarget.SetShowImage(Show: boolean); |
| begin |
| FShowImage := Show; |
| if (DropTargetHelper <> nil) then |
| DropTargetHelper.Show(Show) |
| else |
| if (FDataObject <> nil) then |
| ImageList_DragShowNolock(FShowImage); |
| end; |
| function TCustomDropTarget.GetValidDropEffect(ShiftState: TShiftState; |
| pt: TPoint; dwEffect: LongInt): LongInt; |
| begin |
| // dwEffect 'in' parameter = set of drop effects allowed by drop source. |
| // Now filter out the effects disallowed by target... |
| Result := dwEffect AND DragTypesToDropEffect(FDragTypes); |
| Result := ShiftStateToDropEffect(ShiftState, Result, True); |
| // Add Scroll effect if necessary... |
| if (FAutoScroll) and (FScrollBars <> []) then |
| begin |
| // If the cursor is inside the no-scroll zone, clear the drag scroll flag, |
| // otherwise set it. |
| if (PtInRect(FNoScrollZone, pt)) then |
| Result := Result AND NOT integer(DROPEFFECT_SCROLL) |
| else |
| Result := Result OR integer(DROPEFFECT_SCROLL); |
| end; |
| // 'Default' behaviour can be overriden by assigning OnGetDropEffect. |
| if Assigned(FOnGetDropEffect) then |
| FOnGetDropEffect(Self, ShiftState, pt, Result); |
| end; |
| function TCustomDropTarget.GetPreferredDropEffect: LongInt; |
| begin |
| with TPreferredDropEffectClipboardFormat.Create do |
| try |
| if GetData(DataObject) then |
| Result := Value |
| else |
| Result := DROPEFFECT_NONE; |
| finally |
| Free; |
| end; |
| end; |
| function TCustomDropTarget.SetPasteSucceded(Effect: LongInt): boolean; |
| var |
| Medium: TStgMedium; |
| begin |
| with TPasteSuccededClipboardFormat.Create do |
| try |
| Value := Effect; |
| Result := SetData(DataObject, FormatEtc, Medium); |
| finally |
| Free; |
| end; |
| end; |
| function TCustomDropTarget.SetPerformedDropEffect(Effect: longInt): boolean; |
| var |
| Medium: TStgMedium; |
| begin |
| with TPerformedDropEffectClipboardFormat.Create do |
| try |
| Value := Effect; |
| Result := SetData(DataObject, FormatEtc, Medium); |
| finally |
| Free; |
| end; |
| end; |
| (* |
| The basic procedure for a delete-on-paste operation is as follows (from MSDN): |
| 1) The source marks the screen display of the selected data. |
| 2) The source creates a data object. It indicates a cut operation by adding the |
| CFSTR_PREFERREDDROPEFFECT format with a data value of DROPEFFECT_MOVE. |
| 3) The source places the data object on the Clipboard using OleSetClipboard. |
| 4) The target retrieves the data object from the Clipboard using |
| OleGetClipboard. |
| 5) The target extracts the CFSTR_PREFERREDDROPEFFECT data. If it is set to only |
| DROPEFFECT_MOVE, the target can either do an optimized move or simply copy |
| the data. |
| 6) If the target does not do an optimized move, it calls the |
| IDataObject::SetData method with the CFSTR_PERFORMEDDROPEFFECT format set |
| to DROPEFFECT_MOVE. |
| 7) When the paste is complete, the target calls the IDataObject::SetData method |
| with the CFSTR_PASTESUCCEEDED format set to DROPEFFECT_MOVE. |
| 8) When the source's IDataObject::SetData method is called with the |
| CFSTR_PASTESUCCEEDED format set to DROPEFFECT_MOVE, it must check to see if it |
| also received the CFSTR_PERFORMEDDROPEFFECT format set to DROPEFFECT_MOVE. If |
| both formats are sent by the target, the source will have to delete the data. |
| If only the CFSTR_PASTESUCCEEDED format is received, the source can simply |
| remove the data from its display. If the transfer fails, the source updates |
| the display to its original appearance. |
| *) |
| function TCustomDropTarget.PasteFromClipboard: longint; |
| var |
| Effect: longInt; |
| begin |
| // Get an IDataObject interface to the clipboard. |
| // Temporarily pretend that the IDataObject has been dropped on the target. |
| OleCheck(OleGetClipboard(FDataObject)); |
| try |
| Effect := GetPreferredDropEffect; |
| // Get data from the IDataObject. |
| if (GetData(Effect)) then |
| Result := Effect |
| else |
| Result := DROPEFFECT_NONE; |
| DoOnPaste(Result); |
| finally |
| // Clean up |
| FDataObject := nil; |
| end; |
| end; |
| procedure TCustomDropTarget.DoOnPaste(var Effect: longint); |
| begin |
| // Generate an OnDrop event |
| DoDrop([], Point(0,0), Effect); |
| // Report performed drop effect back to data originator. |
| if (Effect <> DROPEFFECT_NONE) then |
| // Delete on paste: |
| // We now set the CF_PASTESUCCEDED format to indicate to the source |
| // that we are using the "delete on paste" protocol and that the |
| // paste has completed. |
| SetPasteSucceded(Effect); |
| end; |
| procedure TCustomDropTarget.Assign(Source: TPersistent); |
| begin |
| if (Source is TClipboard) then |
| PasteFromClipboard |
| else if (Source.GetInterface(IDataObject, FDataObject)) then |
| begin |
| try |
| // Get data from the IDataObject |
| if (not GetData(DROPEFFECT_COPY)) then |
| inherited Assign(Source); |
| finally |
| // Clean up |
| FDataObject := nil; |
| end; |
| end else |
| inherited Assign(Source); |
| end; |
| procedure TCustomDropTarget.DoAutoScroll(Sender: TObject); |
| var |
| Scroll: TScrolDirections; |
| Interval: integer; |
| begin |
| // Disable timer until we are ready to auto-repeat the scroll. |
| // If no scroll is performed, the scroll stops here. |
| FScrollTimer.Enabled := False;; |
| Interval := DragDropScrollInterval; |
| Scroll := []; |
| // Only scroll if the pointer is outside the non-scroll area |
| if (not PtInRect(FNoScrollZone, FLastPoint)) then |
| begin |
| with FLastPoint do |
| begin |
| // Determine which way to scroll. |
| if (Y < FNoScrollZone.Top) then |
| include(Scroll, sdUp) |
| else if (Y > FNoScrollZone.Bottom) then |
| include(Scroll, sdDown); |
| if (X < FNoScrollZone.Left) then |
| include(Scroll, sdLeft) |
| else if (X > FNoScrollZone.Right) then |
| include(Scroll, sdRight); |
| end; |
| end; |
| DoScroll(FLastPoint, Scroll, Interval); |
| // Note: Once the OnScroll event has been fired and the user has had a |
| // chance of overriding the auto scroll logic, we should *only* use to Scroll |
| // variable to determine if and how to scroll. Do not use FScrollBars past |
| // this point. |
| // Only scroll if the pointer is outside the non-scroll area |
| if (Scroll <> []) then |
| begin |
| // Remove drag image before scrolling |
| if (FDragImageHandle <> 0) then |
| ImageList_DragLeave(FTarget.Handle); |
| try |
| if (sdUp in Scroll) then |
| FTarget.Perform(WM_VSCROLL,SB_LINEUP, 0) |
| else if (sdDown in Scroll) then |
| FTarget.Perform(WM_VSCROLL,SB_LINEDOWN, 0); |
| if (sdLeft in Scroll) then |
| FTarget.Perform(WM_HSCROLL,SB_LINEUP, 0) |
| else if (sdRight in Scroll) then |
| FTarget.Perform(WM_HSCROLL,SB_LINEDOWN, 0); |
| finally |
| // Restore drag image |
| if (FDragImageHandle <> 0) then |
| with ClientPtToWindowPt(FTarget.Handle, FLastPoint) do |
| ImageList_DragEnter(FTarget.Handle, x, y); |
| end; |
| // Reset scroll timer interval once timer has fired once. |
| FScrollTimer.Interval := Interval; |
| FScrollTimer.Enabled := True; |
| end; |
| end; |
| procedure TCustomDropTarget.DoScroll(Point: TPoint; |
| var Scroll: TScrolDirections; var Interval: integer); |
| begin |
| if Assigned(FOnScroll) then |
| FOnScroll(Self, FLastPoint, Scroll, Interval); |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TDropDummy |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| function TDropDummy.HasValidFormats(ADataObject: IDataObject): boolean; |
| begin |
| Result := False; |
| end; |
| procedure TDropDummy.ClearData; |
| begin |
| // Abstract method override - doesn't do anything as you can see. |
| end; |
| function TDropDummy.DoGetData: boolean; |
| begin |
| Result := False; |
| end; |
| //////////////////////////////////////////////////////////////////////////////// |
| // |
| // TCustomDropMultiTarget |
| // |
| //////////////////////////////////////////////////////////////////////////////// |
| constructor TCustomDropMultiTarget.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| DragTypes := [dtLink, dtCopy]; |
| GetDataOnEnter := False; |
| FDataFormats := TDataFormats.Create; |
| end; |
| destructor TCustomDropMultiTarget.Destroy; |
| var |
| i : integer; |
| begin |
| // Delete all target formats owned by the object. |
| for i := FDataFormats.Count-1 downto 0 do |
| FDataFormats[i].Free; |
| FDataFormats.Free; |
| inherited Destroy; |
| end; |
| function TCustomDropMultiTarget.HasValidFormats(ADataObject: IDataObject): boolean; |
| var |
| GetNum , |
| GotNum : longInt; |
| FormatEnumerator : IEnumFormatEtc; |
| i : integer; |
| SourceFormatEtc : TFormatEtc; |
| begin |
| Result := False; |
| if (ADataObject.EnumFormatEtc(DATADIR_GET, FormatEnumerator) <> S_OK) or |
| (FormatEnumerator.Reset <> S_OK) then |
| exit; |
| GetNum := 1; // Get one format at a time. |
| // Enumerate all data formats offered by the drop source. |
| // Note: Depends on order of evaluation. |
| while (not Result) and |
| (FormatEnumerator.Next(GetNum, SourceFormatEtc, @GotNum) = S_OK) and |
| (GetNum = GotNum) do |
| begin |
| // Determine if any of the associated clipboard formats can |
| // read the current data format. |
| for i := 0 to FDataFormats.Count-1 do |
| if (FDataFormats[i].AcceptFormat(SourceFormatEtc)) and |
| (FDataFormats[i].HasValidFormats(ADataObject)) then |
| begin |
| Result := True; |
| DoAcceptFormat(FDataFormats[i], Result); |
| if (Result) then |
| break; |
| end; |
| end; |
| end; |
| procedure TCustomDropMultiTarget.ClearData; |
| var |
| i : integer; |
| begin |
| if (AsyncTransfer) then |
| raise Exception.Create(sAsyncBusy); |
| for i := 0 to DataFormats.Count-1 do |
| DataFormats[i].Clear; |
| end; |
| function TCustomDropMultiTarget.DoGetData: boolean; |
| var |
| i: integer; |
| Accept: boolean; |
| begin |
| Result := False; |
| // Get data for all target formats |
| for i := 0 to DataFormats.Count-1 do |
| begin |
| // This isn't strictly nescessary and adds overhead, but it reduces |
| // unnescessary calls to DoAcceptData (format is asked if it can accept data |
| // even though no data is available to the format). |
| if not(FDataFormats[i].HasValidFormats(DataObject)) then |
| continue; |
| // Only get data from accepted formats. |
| // TDropComboTarget uses the DoAcceptFormat method to filter formats and to |
| // allow the user to disable formats via an event. |
| Accept := True; |
| DoAcceptFormat(DataFormats[i], Accept); |
| if (not Accept) then |
| Continue; |
| Result := DataFormats[i].GetData(DataObject) or Result; |
| end; |
| end; |
| procedure TCustomDropMultiTarget.DoAcceptFormat(const DataFormat: TCustomDataFormat; |
| var Accept: boolean); |
| begin |
| if Assigned(FOnAcceptFormat) then |
| FOnAcceptFormat(Self, DataFormat, Accept); |
| end; |
| end. |
| /trunk/VCL_DRAGDROP/DropTargetCur.res |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DropURLSource.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DropURLSource.pas |
|---|
| 0,0 → 1,217 |
| unit DropURLSource; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite |
| // Component Names: TDropURLSource |
| // Module: DropURLSource |
| // Description: Implements Dragging & Dropping of URLs |
| // FROM your application to another. |
| // Version: 3.7 |
| // Date: 22-APR-1999 |
| // Target: Win32, Delphi 3 - Delphi 5, C++ Builder 3, C++ Builder 4 |
| // Authors: Angus Johnson, ajohnson@rpi.net.au |
| // Anders Melander, anders@melander.dk |
| // http://www.melander.dk |
| // Copyright © 1997-99 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DropSource, |
| Classes, ActiveX; |
| {$include DragDrop.inc} |
| type |
| TDropURLSource = class(TDropSource) |
| private |
| fURL: String; |
| fTitle: String; |
| protected |
| function DoGetData(const FormatEtcIn: TFormatEtc; OUT Medium: TStgMedium):HRESULT; Override; |
| public |
| constructor Create(aOwner: TComponent); Override; |
| function CutOrCopyToClipboard: boolean; Override; |
| published |
| property URL: String Read fURL Write fURL; |
| property Title: String Read fTitle Write fTitle; |
| end; |
| procedure Register; |
| implementation |
| uses |
| Windows, |
| SysUtils, |
| ClipBrd, |
| ShlObj; |
| procedure Register; |
| begin |
| RegisterComponents('DragDrop', [TDropURLSource]); |
| end; |
| // ----------------------------------------------------------------------------- |
| function ConvertURLToFilename(url: string): string; |
| const |
| Invalids = '\/:?*<>,|''"'; |
| var |
| i: integer; |
| begin |
| if lowercase(copy(url,1,7)) = 'http://' then |
| url := copy(url,8,128) // limit to 120 chars. |
| else if lowercase(copy(url,1,6)) = 'ftp://' then |
| url := copy(url,7,127) |
| else if lowercase(copy(url,1,7)) = 'mailto:' then |
| url := copy(url,8,128) |
| else if lowercase(copy(url,1,5)) = 'file:' then |
| url := copy(url,6,126); |
| if url = '' then url := 'untitled'; |
| result := url; |
| for i := 1 to length(result) do |
| if result[i] = '/'then |
| begin |
| result := copy(result,1,i-1); |
| break; |
| end |
| else if pos(result[i],Invalids) <> 0 then |
| result[i] := ' '; |
| appendstr(result,'.url'); |
| end; |
| // ----------------------------------------------------------------------------- |
| // TDropURLSource |
| // ----------------------------------------------------------------------------- |
| constructor TDropURLSource.Create(aOwner: TComponent); |
| begin |
| inherited Create(aOwner); |
| fURL := ''; |
| fTitle := ''; |
| DragTypes := [dtLink]; // Only dtLink allowed |
| AddFormatEtc(CF_URL, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL); |
| AddFormatEtc(CF_FILEGROUPDESCRIPTOR, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL); |
| AddFormatEtc(CF_FILECONTENTS, NIL, DVASPECT_CONTENT, 0, TYMED_HGLOBAL); |
| AddFormatEtc(CF_TEXT, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL); |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropURLSource.CutOrCopyToClipboard: boolean; |
| var |
| FormatEtcIn: TFormatEtc; |
| Medium: TStgMedium; |
| begin |
| result := false; |
| FormatEtcIn.cfFormat := CF_URL; |
| FormatEtcIn.dwAspect := DVASPECT_CONTENT; |
| FormatEtcIn.tymed := TYMED_HGLOBAL; |
| if fURL = '' then exit; |
| if GetData(formatetcIn,Medium) = S_OK then |
| begin |
| Clipboard.SetAsHandle(CF_URL,Medium.hGlobal); |
| result := true; |
| end else exit; |
| //render several formats... |
| FormatEtcIn.cfFormat := CF_TEXT; |
| FormatEtcIn.dwAspect := DVASPECT_CONTENT; |
| FormatEtcIn.tymed := TYMED_HGLOBAL; |
| if GetData(formatetcIn,Medium) = S_OK then |
| begin |
| Clipboard.SetAsHandle(CF_TEXT,Medium.hGlobal); |
| result := true; |
| end; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropURLSource.DoGetData(const FormatEtcIn: TFormatEtc; OUT Medium: TStgMedium):HRESULT; |
| const |
| URLPrefix = '[InternetShortcut]'#10'URL='; |
| var |
| pFGD: PFileGroupDescriptor; |
| pText: PChar; |
| begin |
| Medium.tymed := 0; |
| Medium.UnkForRelease := NIL; |
| Medium.hGlobal := 0; |
| //-------------------------------------------------------------------------- |
| if ((FormatEtcIn.cfFormat = CF_URL) or (FormatEtcIn.cfFormat = CF_TEXT)) and |
| (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and |
| (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then |
| begin |
| Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GHND, Length(fURL)+1); |
| if (Medium.hGlobal = 0) then |
| result := E_OUTOFMEMORY |
| else |
| begin |
| medium.tymed := TYMED_HGLOBAL; |
| pText := PChar(GlobalLock(Medium.hGlobal)); |
| try |
| StrCopy(pText, PChar(fURL)); |
| finally |
| GlobalUnlock(Medium.hGlobal); |
| end; |
| result := S_OK; |
| end; |
| end |
| //-------------------------------------------------------------------------- |
| else if (FormatEtcIn.cfFormat = CF_FILECONTENTS) and |
| (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and |
| (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then |
| begin |
| Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GHND, Length(URLPrefix + fURL)+1); |
| if (Medium.hGlobal = 0) then |
| result := E_OUTOFMEMORY |
| else |
| begin |
| medium.tymed := TYMED_HGLOBAL; |
| pText := PChar(GlobalLock(Medium.hGlobal)); |
| try |
| StrCopy(pText, PChar(URLPrefix + fURL)); |
| finally |
| GlobalUnlock(Medium.hGlobal); |
| end; |
| result := S_OK; |
| end; |
| end |
| //-------------------------------------------------------------------------- |
| else if (FormatEtcIn.cfFormat = CF_FILEGROUPDESCRIPTOR) and |
| (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and |
| (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then |
| begin |
| Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GHND, SizeOf(TFileGroupDescriptor)); |
| if (Medium.hGlobal = 0) then |
| begin |
| result := E_OUTOFMEMORY; |
| Exit; |
| end; |
| medium.tymed := TYMED_HGLOBAL; |
| pFGD := pointer(GlobalLock(Medium.hGlobal)); |
| try |
| with pFGD^ do |
| begin |
| cItems := 1; |
| fgd[0].dwFlags := FD_LINKUI; |
| if title = '' then |
| StrPCopy(fgd[0].cFileName,ConvertURLToFilename(fURL)) |
| else |
| StrPCopy(fgd[0].cFileName,ConvertURLToFilename(fTitle)); |
| end; |
| finally |
| GlobalUnlock(Medium.hGlobal); |
| end; |
| result := S_OK; |
| //-------------------------------------------------------------------------- |
| end else |
| result := DV_E_FORMATETC; |
| end; |
| // ----------------------------------------------------------------------------- |
| // ----------------------------------------------------------------------------- |
| end. |
| /trunk/VCL_DRAGDROP/DropURLTarget.dcr |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/DropURLTarget.pas |
|---|
| 0,0 → 1,262 |
| unit DropURLTarget; |
| // ----------------------------------------------------------------------------- |
| // Project: Drag and Drop Component Suite |
| // Component Names: TDropURLTarget |
| // Module: DropURLTarget |
| // Description: Implements Dragging & Dropping of URLs |
| // TO your application from another. |
| // Version: 3.7 |
| // Date: 22-APR-1999 |
| // Target: Win32, Delphi 3 - Delphi 5, C++ Builder 3, C++ Builder 4 |
| // Authors: Angus Johnson, ajohnson@rpi.net.au |
| // Anders Melander, anders@melander.dk |
| // http://www.melander.dk |
| // Copyright © 1997-99 Angus Johnson & Anders Melander |
| // ----------------------------------------------------------------------------- |
| interface |
| uses |
| DropSource, DropTarget, |
| Classes, ActiveX; |
| {$include DragDrop.inc} |
| type |
| TDropURLTarget = class(TDropTarget) |
| private |
| URLFormatEtc, |
| FileContentsFormatEtc, |
| FGDFormatEtc: TFormatEtc; |
| fURL: String; |
| fTitle: String; |
| protected |
| procedure ClearData; override; |
| function DoGetData: boolean; override; |
| function HasValidFormats: boolean; override; |
| public |
| constructor Create(AOwner: TComponent); override; |
| property URL: String Read fURL Write fURL; |
| property Title: String Read fTitle Write fTitle; |
| end; |
| procedure Register; |
| implementation |
| uses |
| Windows, |
| SysUtils, |
| ShlObj; |
| procedure Register; |
| begin |
| RegisterComponents('DragDrop', [TDropURLTarget]); |
| end; |
| // ----------------------------------------------------------------------------- |
| function GetURLFromFile(const Filename: string; var URL: string): boolean; |
| var |
| URLfile : TStringList; |
| i : integer; |
| s : string; |
| p : PChar; |
| begin |
| Result := False; |
| URLfile := TStringList.Create; |
| try |
| URLFile.LoadFromFile(Filename); |
| i := 0; |
| while (i < URLFile.Count-1) do |
| begin |
| if (CompareText(URLFile[i], '[InternetShortcut]') = 0) then |
| begin |
| inc(i); |
| while (i < URLFile.Count) do |
| begin |
| s := URLFile[i]; |
| p := PChar(s); |
| if (StrLIComp(p, 'URL=', length('URL=')) = 0) then |
| begin |
| inc(p, length('URL=')); |
| URL := p; |
| Result := True; |
| exit; |
| end else |
| if (p^ = '[') then |
| exit; |
| inc(i); |
| end; |
| end; |
| inc(i); |
| end; |
| finally |
| URLFile.Free; |
| end; |
| end; |
| // ----------------------------------------------------------------------------- |
| // TDropURLTarget |
| // ----------------------------------------------------------------------------- |
| constructor TDropURLTarget.Create(AOwner: TComponent); |
| begin |
| inherited Create(AOwner); |
| DragTypes := [dtLink]; //Only allow links. |
| GetDataOnEnter := true; |
| with URLFormatEtc do |
| begin |
| cfFormat := CF_URL; |
| ptd := nil; |
| dwAspect := DVASPECT_CONTENT; |
| lindex := -1; |
| tymed := TYMED_HGLOBAL; |
| end; |
| with FileContentsFormatEtc do |
| begin |
| cfFormat := CF_FILECONTENTS; |
| ptd := nil; |
| dwAspect := DVASPECT_CONTENT; |
| lindex := 0; |
| tymed := TYMED_HGLOBAL; |
| end; |
| with FGDFormatEtc do |
| begin |
| cfFormat := CF_FILEGROUPDESCRIPTOR; |
| ptd := nil; |
| dwAspect := DVASPECT_CONTENT; |
| lindex := -1; |
| tymed := TYMED_HGLOBAL; |
| end; |
| end; |
| // ----------------------------------------------------------------------------- |
| //This demonstrates how to enumerate all DataObject formats. |
| function TDropURLTarget.HasValidFormats: boolean; |
| var |
| GetNum, GotNum: longint; |
| FormatEnumerator: IEnumFormatEtc; |
| tmpFormatEtc: TformatEtc; |
| begin |
| result := false; |
| //Enumerate available DataObject formats |
| //to see if any one of the wanted formats is available... |
| if (DataObject.EnumFormatEtc(DATADIR_GET,FormatEnumerator) <> S_OK) or |
| (FormatEnumerator.Reset <> S_OK) then |
| exit; |
| GetNum := 1; //get one at a time... |
| while (FormatEnumerator.Next(GetNum, tmpFormatEtc, @GotNum) = S_OK) and |
| (GetNum = GotNum) do |
| with tmpFormatEtc do |
| if (ptd = nil) and (dwAspect = DVASPECT_CONTENT) and |
| {(lindex <> -1) or} (tymed and TYMED_HGLOBAL <> 0) and |
| ((cfFormat = CF_URL) or (cfFormat = CF_FILECONTENTS) or |
| (cfFormat = CF_HDROP) or (cfFormat = CF_TEXT)) then |
| begin |
| result := true; |
| break; |
| end; |
| end; |
| // ----------------------------------------------------------------------------- |
| procedure TDropURLTarget.ClearData; |
| begin |
| fURL := ''; |
| end; |
| // ----------------------------------------------------------------------------- |
| function TDropURLTarget.DoGetData: boolean; |
| var |
| medium: TStgMedium; |
| cText: pchar; |
| tmpFiles: TStringList; |
| pFGD: PFileGroupDescriptor; |
| begin |
| fURL := ''; |
| fTitle := ''; |
| result := false; |
| //-------------------------------------------------------------------------- |
| if (DataObject.GetData(URLFormatEtc, medium) = S_OK) then |
| begin |
| try |
| if (medium.tymed <> TYMED_HGLOBAL) then |
| exit; |
| cText := PChar(GlobalLock(medium.HGlobal)); |
| fURL := cText; |
| GlobalUnlock(medium.HGlobal); |
| result := true; |
| finally |
| ReleaseStgMedium(medium); |
| end; |
| end |
| //-------------------------------------------------------------------------- |
| else if (DataObject.GetData(TextFormatEtc, medium) = S_OK) then |
| begin |
| try |
| if (medium.tymed <> TYMED_HGLOBAL) then |
| exit; |
| cText := PChar(GlobalLock(medium.HGlobal)); |
| fURL := cText; |
| GlobalUnlock(medium.HGlobal); |
| result := true; |
| finally |
| ReleaseStgMedium(medium); |
| end; |
| end |
| //-------------------------------------------------------------------------- |
| else if (DataObject.GetData(FileContentsFormatEtc, medium) = S_OK) then |
| begin |
| try |
| if (medium.tymed <> TYMED_HGLOBAL) then |
| exit; |
| cText := PChar(GlobalLock(medium.HGlobal)); |
| fURL := cText; |
| fURL := copy(fURL,24,250); |
| GlobalUnlock(medium.HGlobal); |
| result := true; |
| finally |
| ReleaseStgMedium(medium); |
| end; |
| end |
| //-------------------------------------------------------------------------- |
| else if (DataObject.GetData(HDropFormatEtc, medium) = S_OK) then |
| begin |
| try |
| if (medium.tymed <> TYMED_HGLOBAL) then exit; |
| tmpFiles := TStringList.create; |
| try |
| if GetFilesFromHGlobal(medium.HGlobal,TStrings(tmpFiles)) and |
| (lowercase(ExtractFileExt(tmpFiles[0])) = '.url') and |
| GetURLFromFile(tmpFiles[0], fURL) then |
| begin |
| fTitle := extractfilename(tmpFiles[0]); |
| delete(fTitle,length(fTitle)-3,4); //deletes '.url' extension |
| result := true; |
| end; |
| finally |
| tmpFiles.free; |
| end; |
| finally |
| ReleaseStgMedium(medium); |
| end; |
| end; |
| if (DataObject.GetData(FGDFormatEtc, medium) = S_OK) then |
| begin |
| try |
| if (medium.tymed <> TYMED_HGLOBAL) then exit; |
| pFGD := pointer(GlobalLock(medium.HGlobal)); |
| fTitle := pFGD^.fgd[0].cFileName; |
| GlobalUnlock(medium.HGlobal); |
| delete(fTitle,length(fTitle)-3,4); //deletes '.url' extension |
| finally |
| ReleaseStgMedium(medium); |
| end; |
| end |
| else if fTitle = '' then fTitle := fURL; |
| end; |
| // ----------------------------------------------------------------------------- |
| // ----------------------------------------------------------------------------- |
| end. |
| /trunk/VCL_DRAGDROP/dragdropC3.res |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/dragdropC4.res |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |
| /trunk/VCL_DRAGDROP/dragdropC5.res |
|---|
| Cannot display: file marked as a binary type. |
| svn:mime-type = application/octet-stream |
| Property changes: |
| Added: svn:mime-type |
| +application/octet-stream |
| \ No newline at end of property |