这个问题这么久没有回答，看来也只有我自己回答了。昨天下午我用了一个多小时的时间将下面这段代码从DragDrop组件中分离了出来。
unit DropURL;
interface
uses
Windows, Messages, ActiveX, Classes, Controls, ShlObj, ShellApi, SysUtils,
Forms;
type
TDropTargetEvent = procedure(Sender: TObject;
ShiftState: TShiftState;
Point: TPoint;
var Effect: Longint) of Object;
TInterfacedComponent = class(TComponent, IUnknown)
private
fRefCount: Integer;
protected
function QueryInterface(const IID: TGuid;
out Obj): HRESULT;
{$ifdef VER120} reintroduce;
{$endif} stdcall;
function _AddRef: Integer;
stdcall;
function _Release: Integer;
stdcall;
public
property RefCount: Integer read fRefCount;
end;
TDropTarget = class(TInterfacedComponent, IDropTarget)
private
fDataObj: IDataObject;
fRegistered: boolean;
fTarget: TWinControl;
fGetDataOnEnter: boolean;
fOnEnter: TDropTargetEvent;
fOnDragOver: TDropTargetEvent;
fOnLeave: TNotifyEvent;
fOnDrop: TDropTargetEvent;
procedure SetTarget(Target: TWinControl);
protected
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;
functiondo
GetData: boolean;
Virtual;
Abstract;
procedure ClearData;
Virtual;
Abstract;
function HasValidFormats: boolean;
Virtual;
Abstract;
procedure Notification(AComponent: TComponent;
Operation: TOperation);
override;
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
procedure Register(Target: TWinControl);
procedure Unregister;
property DataObject: IDataObject read fDataObj;
property Target: TWinControl read fTarget write SetTarget;
published
property GetDataOnEnter: Boolean read fGetDataOnEnter write fGetDataOnEnter;
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;
end;
TDropURLTarget = class(TDropTarget)
private
URLFormatEtc,
FGDFormatEtc: TFormatEtc;
fURL: String;
fTitle: String;
protected
procedure ClearData;
override;
functiondo
GetData: 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;
const
HDropFormatEtc: TFormatEtc = (cfFormat: CF_HDROP;
ptd: nil;
dwAspect: DVASPECT_CONTENT;
lindex: -1;
tymed: TYMED_HGLOBAL);
var
CF_FILEGROUPDESCRIPTOR, CF_FILECONTENTS,
CF_URL: UINT;
implementation
function TDropTarget.DragEnter(const dataObj: IDataObject;
grfKeyState: Longint;
pt: TPoint;
var dwEffect: Longint): HRESULT;
var
ShiftState: TShiftState;
begin
ClearData;
fDataObj := dataObj;
fDataObj._AddRef;
result := S_OK;
if not HasValidFormats then
begin
fDataObj._Release;
fDataObj := nil;
dwEffect := DROPEFFECT_NONE;
result := E_FAIL;
exit;
end;
if fGetDataOnEnter then
do
GetData;
ShiftState := KeysToShiftState(grfKeyState);
if Assigned(fOnEnter) then
fOnEnter(self, ShiftState, pt, dwEffect);
end;
function TDropTarget.DragOver(grfKeyState: Longint;
pt: TPoint;
var dwEffect: Longint): HResult;
var
ShiftState: TShiftState;
begin
pt := fTarget.ScreenToClient(pt);
ShiftState := KeysToShiftState(grfKeyState);
dwEffect := DROPEFFECT_LINK;
if Assigned(fOnDragOver) then
fOnDragOver(self, ShiftState, pt, dwEffect);
RESULT := S_OK;
end;
function TDropTarget.DragLeave: HResult;
begin
ClearData;
if fDataObj <> nil then
begin
fDataObj._Release;
fDataObj := nil;
end;
if Assigned(fOnLeave) then
fOnLeave(self);
Result := S_OK;
end;
function TDropTarget.Drop(const dataObj: IDataObject;
grfKeyState: Longint;
pt: TPoint;
var dwEffect: Longint): HResult;
var
ShiftState: TShiftState;
begin
RESULT := S_OK;
ShiftState := KeysToShiftState(grfKeyState);
pt := fTarget.ScreenToClient(pt);
dwEffect := DROPEFFECT_LINK;
if (not fGetDataOnEnter) and (notdo
GetData) then
dwEffect := DROPEFFECT_NONE
else
if Assigned(fOnDrop) then
fOnDrop(Self, ShiftState, pt, dwEffect);
ClearData;
if fDataObj = nil then
exit;
fDataObj._Release;
fDataObj := nil;
end;
constructor TDropTarget.Create( AOwner: TComponent );
begin
inherited Create( AOwner );
_AddRef;
fGetDataOnEnter := false;
fDataObj := nil;
OleInitialize(NIL);
CF_FILECONTENTS := RegisterClipboardFormat(CFSTR_FILECONTENTS);
CF_FILEGROUPDESCRIPTOR := RegisterClipboardFormat(CFSTR_FILEDESCRIPTOR);
CF_URL := RegisterClipboardFormat('UniformResourceLocator');
end;
destructor TDropTarget.Destroy;
begin
Unregister;
OleUninitialize;
inherited Destroy;
end;
procedure TDropTarget.SetTarget(Target: TWinControl);
begin
if fTarget = Target then
exit;
Unregister;
fTarget := Target;
end;
procedure TDropTarget.Register(Target: TWinControl);
begin
if fTarget = Target then
exit;
if (fTarget <> nil) then
Unregister;
fTarget := target;
if fTarget = nil then
exit;
if not RegisterDragDrop(fTarget.handle,self) = S_OK then
raise Exception.create('Failed to Register '+ fTarget.name);
fRegistered := true;
end;
procedure TDropTarget.Unregister;
begin
fRegistered := false;
if (fTarget = nil) or not fTarget.handleallocated then
exit;
if not RevokeDragDrop(fTarget.handle) = S_OK then
raise Exception.create('Failed to Unregister '+ fTarget.name);
fTarget := nil;
end;
procedure TDropTarget.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
end;
function TInterfacedComponent.QueryInterface(const IID: TGuid;
out Obj): HRESULT;
begin
if GetInterface(IID, Obj) then
result := 0 else
result := E_NOINTERFACE;
end;
function TInterfacedComponent._AddRef: Integer;
begin
result := InterlockedIncrement(fRefCount);
end;
function TInterfacedComponent._Release: Integer;
begin
Result := InterlockedDecrement(fRefCount);
if (Result = 0) then
Free;
end;
constructor TDropURLTarget.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
GetDataOnEnter := true;
with URLFormatEtcdo
begin
cfFormat := CF_URL;
ptd := nil;
dwAspect := DVASPECT_CONTENT;
lindex := -1;
tymed := TYMED_HGLOBAL;
end;
with FGDFormatEtcdo
begin
cfFormat := CF_FILEGROUPDESCRIPTOR;
ptd := nil;
dwAspect := DVASPECT_CONTENT;
lindex := -1;
tymed := TYMED_HGLOBAL;
end;
end;
function TDropURLTarget.HasValidFormats: boolean;
var
GetNum, GotNum: longint;
FormatEnumerator: IEnumFormatEtc;
tmpFormatEtc: TformatEtc;
begin
result := false;
if (DataObject.EnumFormatEtc(DATADIR_GET,FormatEnumerator) <> S_OK) or
(FormatEnumerator.Reset <> S_OK) then
exit;
GetNum := 1;
while (FormatEnumerator.Next(GetNum, tmpFormatEtc, @GotNum) = S_OK) and
(GetNum = GotNum)do
with tmpFormatEtcdo
if (ptd = nil) and (dwAspect = DVASPECT_CONTENT) and
(tymed and TYMED_HGLOBAL <> 0) and ((cfFormat = CF_URL)
or (cfFormat = CF_FILECONTENTS) or (cfFormat = CF_HDROP)) then
begin
result := true;
break;
end;
end;
procedure TDropURLTarget.ClearData;
begin
fURL := '';
end;
function TDropURLTarget.DoGetData: boolean;
var
medium: TStgMedium;
cText: pchar;
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;
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;
delete(fTitle,length(fTitle)-3,4);
finally
ReleaseStgMedium(medium);
end;
end
else
if fTitle = '' then
fTitle := fURL;
end;
end.
//OnCreate
DropURLTarget1:=TDropURLTarget.Create(Self);
DropURLTarget1.OnDrop:=DropURLTarget1Drop;
DropURLTarget1.Register(Panel1);
//OnDrop
procedure TForm1.DropURLTarget1Drop(Sender: TObject;
ShiftState: TShiftState;
Point: TPoint;
var Effect: Integer);
begin
if DropURLTarget1.URL<>'' then
MessageBox(GetForegroundWindow,PChar(DropURLTarget1.Url+#13#10+DropURLTarget1.Title),PChar(HintMessage),MB_OK);
end;
//OnDestory
DropURLTarget1.Unregister;
DropURLTarget1.Free;
