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.