一个OLE拖放组件

unit DropWrap;
////////////////////////////////////////////////////////////////////////////////
//
// TMyOLEDragDropInterface - a simple wrapper component to implement
// OLE Drag and Drop.
//
// Copyright 1998 by Andreas Hahn
// andreas.hahn@sap-ag.de
//
// Free to use, edit and redistribute as long as my name appears somewhere
// in the source code.
// No warranty is given by the author, expressed or limited.
// (this was for our american friends -)
//
// Comments, bug-reports etc are welcome. I would be glad if you drop me a
// line when modifying the source to keep track of the code history.
//
////////////////////////////////////////////////////////////////////////////////
//
// History :
//
// 01-31-1998 created, initial release 0.9
//
////////////////////////////////////////////////////////////////////////////////
interface
uses
Windows, SysUtils, Classes, Controls, ActiveX;
const ClipBoardFormatIDString = 'MyDragDrop Format';
type
TMyDropEffect = (deNone, deCopy, deMove, deLink, deScroll);
TMyAllowedDropEffects = set of deCopy..deScroll;
TMyDropEvent = procedure(DropString : string; Point : TPoint) of object;
TMyDragEvent = procedure(DropEffect : TMyDropEffect) of object;
TMyDragObject = class;
TMyDropObject = class;
TMyOLEDragDropInterface = class(TComponent)
private
FDragDropControl : TWinControl;
MyDragObject : TMyDragObject;
MyDropTarget : TMyDropObject;
FOnDrop : TMyDropEvent;
FOnDragFinished : TMyDragEvent;
FDropEffect : TMyDropEffect;
FAllowedDragEffects,
FAllowedDropEffects : TMyAllowedDropEffects;
FPointDroped : TPoint;
FStringDroped,
FStringToDrag : string;
FIsInDragging : Boolean;
procedure SetDragDropControl(NewValue : TWinControl);
protected
function GetReqBufferSize: LongInt;
procedure SetReqBufferSize(ASize : LongInt);
procedure DoDropFinished;
procedure DoDragFinished;
procedure SetDragObjectData(MemBuffer : Pointer);
procedure SetDropObjectData(MemBuffer : Pointer);
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
procedure StartDrag(StringToDrag : string);
published
property IsInDragging : Boolean read FIsInDragging;
property AllowedDragEffects : TMyAllowedDropEffects read FAllowedDragEffects write FAllowedDragEffects;
property AllowedDropEffects : TMyAllowedDropEffects read FAllowedDropEffects write FAllowedDropEffects;
property DragDropControl : TWinControl read FDragDropControl write SetDragDropControl;
property OnDrop : TMyDropEvent read FOnDrop write FOnDrop;
property OnDragFinished : TMyDragEvent read FOnDragFinished write FOnDragFinished;
end;
TMyEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc)
private
FmtPtr : LongInt;
public
constructor Create;
// IEnumFormatEtc interface
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;
TMyDragObject = class(TInterfacedObject, IDataObject, IDropSource)
private
// internal stuff
ParentHandler : TMyOLEDragDropInterface;
DragEffect : LongInt;
public
// IDataObject interface
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;
// IDropSource interface
function QueryContinueDrag(fEscapePressed: BOOL;
grfKeyState: Longint): HResult; stdcall;
function GiveFeedback(dwEffect: Longint): HResult; stdcall;
end;
TMyDropObject = class(TInterfacedObject, IDropTarget)
private
// internal stuff
ParentHandler : TMyOLEDragDropInterface;
public
// IDropTarget interface
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;
end;
EMyOLEDragDropInterfaceException = class(Exception);
implementation
var MyFormatEtc : TFormatEtc;
CF_MyDragDrop : LongInt;
function CheckClipboardFormat(dataObj: IDataObject): Boolean;
begin
Result := Succeeded(dataObj.QueryGetData(MyFormatEtc));
end;
// here we translate the standard key behaviour
function TranslateKeyStateToDragEffect(KS : Longint; ADE : TMyAllowedDropEffects): LongInt;
begin
// none by default
Result := DROPEFFECT_NONE;
// move is default without key pressed
if deMove in ADE
then Result := DROPEFFECT_MOVE;
// copy
if (KS and MK_CONTROL) = MK_CONTROL then
begin
if deCopy in ADE
then Result := DROPEFFECT_COPY;
// link
if (KS and MK_SHIFT) = MK_SHIFT then
if deLink in ADE
then Result := DROPEFFECT_LINK;
end;
end;
////////////////////////////////////////////////////////////////////////////////
constructor TMyOLEDragDropInterface.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
FDragDropControl := nil;
FAllowedDragEffects := [deCopy, deMove, deLink];
FAllowedDropEffects := [deCopy, deMove, deLink];
MyDropTarget := TMyDropObject.Create;
MyDropTarget.ParentHandler := Self;
MyDropTarget._AddRef;
end;
destructor TMyOLEDragDropInterface.Destroy;
begin
MyDropTarget._Release;
inherited Destroy;
end;
procedure TMyOLEDragDropInterface.SetDragDropControl(NewValue : TWinControl);
var RegisterResult : HResult;
ErrorStr : string;
begin
if NewValue <> FDragDropControl then
begin
if FDragDropControl <> nil then
begin
// first unregister old window
RegisterResult := RevokeDragDrop(FDragDropControl.Handle);
if (RegisterResult <> S_OK) and (RegisterResult <> DRAGDROP_E_NOTREGISTERED) then
begin
case RegisterResult of
DRAGDROP_E_INVALIDHWND : ErrorStr := 'Invalid window handle';
E_OUTOFMEMORY : ErrorStr := 'Out of memory';
end;
FDragDropControl := nil;
raise EMyOLEDragDropInterfaceException.Create(ErrorStr);
end;
end;
// now register new window
RegisterResult := RegisterDragDrop(NewValue.Handle, MyDropTarget as IDropTarget);
if (RegisterResult <> S_OK) and (RegisterResult <> DRAGDROP_E_ALREADYREGISTERED) then
begin
case RegisterResult of
DRAGDROP_E_INVALIDHWND : ErrorStr := 'Invalid window handle';
E_OUTOFMEMORY : ErrorStr := 'Out of memory';
end;
raise EMyOLEDragDropInterfaceException.Create(ErrorStr);
end;
FDragDropControl := NewValue;
end;
end;
procedure TMyOLEDragDropInterface.StartDrag(StringToDrag : string);
var dwDropEffect : LongInt;
begin
dwDropEffect := DROPEFFECT_NONE;
if deCopy in FAllowedDragEffects
then dwDropEffect := dwDropEffect or DROPEFFECT_COPY;
if deMove in FAllowedDragEffects
then dwDropEffect := dwDropEffect or DROPEFFECT_MOVE;
if deLink in FAllowedDragEffects
then dwDropEffect := dwDropEffect or DROPEFFECT_LINK;
FStringToDrag := StringToDrag;
MyDragObject := TMyDragObject.Create;
MyDragObject._AddRef;
MyDragObject.ParentHandler := Self;
FIsInDragging := true;
DoDragDrop(MyDragObject as IDataObject, MyDragObject as IDropSource,
dwDropEffect, MyDragObject.DragEffect);
dwDropEffect := MyDragObject.DragEffect;
MyDragObject._Release;
if (dwDropEffect and DROPEFFECT_NONE) = DROPEFFECT_NONE
then FDropEffect := deNone;
if (dwDropEffect and DROPEFFECT_COPY) = DROPEFFECT_COPY
then FDropEffect := deCopy;
if (dwDropEffect and DROPEFFECT_MOVE) = DROPEFFECT_MOVE
then FDropEffect := deMove;
if (dwDropEffect and DROPEFFECT_LINK) = DROPEFFECT_LINK
then FDropEffect := deLink;
FIsInDragging := false;
DoDragFinished;
end;
function TMyOLEDragDropInterface.GetReqBufferSize: LongInt;
begin
Result := Length(FStringToDrag) + 1;
end;
procedure TMyOLEDragDropInterface.SetReqBufferSize(ASize : LongInt);
begin
// does nothing here, used for extensions
end;
procedure TMyOLEDragDropInterface.SetDragObjectData(MemBuffer : Pointer);
begin
// copy data only if drop succesful
StrPCopy(MemBuffer, FStringToDrag);
end;
procedure TMyOLEDragDropInterface.SetDropObjectData(MemBuffer : Pointer);
begin
FStringDroped := StrPas(MemBuffer);
end;
procedure TMyOLEDragDropInterface.DoDropFinished;
begin
if Assigned(FOnDrop)
then FOnDrop(FStringDroped, FDragDropControl.ScreenToClient(FPointDroped));
end;
procedure TMyOLEDragDropInterface.DoDragFinished;
begin
if Assigned(FOnDragFinished)
then FOnDragFinished(FDropEffect);
end;
////////////////////////////////////////////////////////////////////////////////
constructor TMyEnumFormatEtc.Create;
begin
inherited Create;
Reset;
end;
function TMyEnumFormatEtc.Next(celt: Longint; out elt; pceltFetched: PLongint): HResult;
begin
Result := S_FALSE;
// all out ?
if FmtPtr = 1
then Exit;
Pointer(elt) := @MyFormatEtc;
Inc(FmtPtr);
if pceltFetched <> nil
then pceltFetched^ := 1;
if celt = 1
then Result := S_OK;
end;
function TMyEnumFormatEtc.Skip(celt: Longint): HResult;
begin
if FmtPtr + celt > 1 then
begin
Result := S_FALSE;
Exit;
end;
FmtPtr := FmtPtr + celt;
Result := S_OK;
end;
function TMyEnumFormatEtc.Reset: HResult;
begin
FmtPtr := 1;
Result := S_OK;
end;
function TMyEnumFormatEtc.Clone(out enum: IEnumFormatEtc): HResult;
var NewEnum : TMyEnumFormatEtc;
begin
// create object
NewEnum := TMyEnumFormatEtc.Create;
if NewEnum = nil then
begin
Result := E_OUTOFMEMORY;
Exit;
end;
// clone current state
NewEnum.FmtPtr := FmtPtr;
enum := NewEnum;
Result := S_OK;
end;
////////////////////////////////////////////////////////////////////////////////
function TMyDragObject.GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult;
var MemHandle : THandle;
MemPointer : Pointer;
begin
// look if format ok
Result := QueryGetData(formatetcIn);
if Failed(Result)
then Exit;
MemHandle := GlobalAlloc(GMEM_MOVEABLE, ParentHandler.GetReqBufferSize);
try
MemPointer := GlobalLock(MemHandle);
ParentHandler.SetDragObjectData(MemPointer);
GlobalUnlock(MemHandle);
medium.tymed := TYMED_HGLOBAL;
medium.hGlobal := MemHandle;
// receiver shall free memory
medium.unkForRelease := nil;
except
Result := E_UNEXPECTED;
GlobalFree(MemHandle);
end;
end;
function TMyDragObject.GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult;
begin
Result := E_NOTIMPL;
end;
function TMyDragObject.QueryGetData(const formatetc: TFormatEtc): HResult;
begin
with formatetc do
begin
if cfFormat <> MyFormatEtc.cfFormat
then Result := DV_E_FORMATETC
else
if dwAspect <> MyFormatEtc.dwAspect
then Result := DV_E_DVASPECT
else if lindex <> MyFormatEtc.lindex
then Result := DV_E_LINDEX
else if tymed <> MyFormatEtc.tymed
then Result := DV_E_TYMED
else Result := S_OK;
end;
end;
function TMyDragObject.GetCanonicalFormatEtc(const formatetc: TFormatEtc; out formatetcOut: TFormatEtc): HResult;
begin
Result := E_NOTIMPL;
end;
function TMyDragObject.SetData(const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult;
begin
Result := E_NOTIMPL;
end;
function TMyDragObject.EnumFormatEtc(dwDirection: Longint; out enumFormatEtc: IEnumFormatEtc): HResult;
begin
if dwDirection = DATADIR_SET then
begin
Result := E_NOTIMPL;
Exit;
end;
enumFormatEtc := TMyEnumFormatEtc.Create;
if enumFormatEtc = nil
then Result := E_OUTOFMEMORY
else Result := S_OK;
end;
function TMyDragObject.DAdvise(const formatetc: TFormatEtc; advf: Longint; const advSink: IAdviseSink; out dwConnection: Longint): HResult;
begin
Result := E_NOTIMPL;
end;
function TMyDragObject.DUnadvise(dwConnection: Longint): HResult;
begin
Result := E_NOTIMPL;
end;
function TMyDragObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult;
begin
Result := E_NOTIMPL;
end;
function TMyDragObject.QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult;
begin
Result := S_OK;
// cancel drag on escape
if fEscapePressed
then Result := DRAGDROP_S_CANCEL;
// commit drag on left mouse button up
if (grfKeyState and MK_LBUTTON) <> MK_LBUTTON
then Result := DRAGDROP_S_DROP;
end;
function TMyDragObject.GiveFeedback(dwEffect: Longint): HResult;
begin
Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;
////////////////////////////////////////////////////////////////////////////////
function TMyDropObject.DragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;
begin
// no data object, no acceptance
// query clipboard format
if (dataObj = nil) or (not CheckClipboardFormat(dataObj)) then
begin
Result := E_FAIL;
Exit;
end;
// proceed with standard keys
dwEffect := TranslateKeyStateToDragEffect(grfKeyState, ParentHandler.AllowedDropEffects);
Result := S_OK;
end;
function TMyDropObject.DragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;
begin
// proceed with standard keys
dwEffect := TranslateKeyStateToDragEffect(grfKeyState, ParentHandler.AllowedDropEffects);
Result := S_OK;
end;
function TMyDropObject.DragLeave: HResult;
begin
Result := S_OK;
end;
function TMyDropObject.Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;
var medium : TStgMedium;
MemPointer : Pointer;
begin
Result := E_FAIL;
// no data object, no acceptance
// query clipboard format
if (dataObj = nil) or (not CheckClipboardFormat(dataObj))
then Exit;
Result := dataObj.GetData(MyFormatEtc, medium);
if Failed(Result)
then Exit;
ParentHandler.SetReqBufferSize(GlobalSize(medium.hGlobal));
MemPointer := GlobalLock(medium.hGlobal);
try
ParentHandler.SetDropObjectData(MemPointer);
ParentHandler.FPointDroped := pt;
finally
GlobalUnlock(medium.hGlobal);
ReleaseStgMedium(medium);
end;
_AddRef;
try
ParentHandler.DoDropFinished;
finally
_Release;
end;
dwEffect := TranslateKeyStateToDragEffect(grfKeyState, ParentHandler.AllowedDropEffects);
Result := S_OK;
end;
initialization
OleInitialize(nil);
CF_MyDragDrop := RegisterClipboardFormat(ClipBoardFormatIDString);
with MyFormatEtc do
begin
cfFormat := CF_MyDragDrop;
ptd := nil;
dwAspect := DVASPECT_CONTENT;
lindex := -1;
tymed := TYMED_HGLOBAL;
end;
finalization
OleUnInitialize;
end.