URL拖放支持

unit DragDrop;
interface
uses
 Windows, ActiveX, ComObj,Dialogs,Sysutils;
type
 TDropEvent = procedure(Sender:TObject;Msg:Pchar)of object;
 TTMyDrop = class(TComObject, IDropTarget)
 private
   FOnDroped: TDropEvent;
   procedure SetOnDroped(const Value: TDropEvent);
 protected
   {Declare IDropTarget methods here}
   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;
 public
   property OnDroped:TDropEvent read FOnDroped write SetOnDroped;
 end;
const
 Class_TMyDrop: TGUID = '{846C94F8-7649-11D2-9836-0000E82EA1B1}';
implementation
uses ComServ,unit1;
{ TTMyDrop }
function TTMyDrop.DragEnter(const dataObj: IDataObject;
 grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
var
 enumFormatEtc: IEnumFormatEtc;
 f:TFORMATETC;
 count:Integer;
 Found:boolean;
begin
 dataObj.EnumFormatEtc(DATADIR_GET,enumFormatEtc);
 Found:=false;
 while (enumFormatEtc.Next(1,f,@count)=S_OK)and (count>0) do
 begin
   if (f.cfFormat=CF_TEXT) then
   begin
     Found:=true;
     Break;
   end;
 end;
 if Found then
   Result:=S_OK
 else
 begin
   result:=E_INVALIDARG;
   dwEffect:=DROPEFFECT_NONE;
 end;
end;
function TTMyDrop.DragLeave: HResult;
begin
  result := S_OK;
end;
function TTMyDrop.DragOver(grfKeyState: Integer; pt: TPoint;
 var dwEffect: Integer): HResult;
begin
  result := S_OK;
end;
function TTMyDrop.Drop(const dataObj: IDataObject; grfKeyState: Integer;
 pt: TPoint; var dwEffect: Integer): HResult;
var
 enumFormatEtc: IEnumFormatEtc;
 f:TFORMATETC;
 count:Integer;
 Found:boolean;
 medium: TStgMedium;
begin
 dataObj.EnumFormatEtc(DATADIR_GET,enumFormatEtc);
 Found:=false;
 while (enumFormatEtc.Next(1,f,@count)=S_OK)and (count>0) do
 begin
   if (f.cfFormat=CF_TEXT) then
   begin
     Found:=true;
     Break;
   end;
 end;
 if not Found then
 begin
   result:=E_INVALIDARG;
   dwEffect:=DROPEFFECT_NONE;
   Exit;
 end;
 dataObj.GetData(f,medium);
 if medium.tymed =1 then
 begin
   if Assigned(fOnDroped) then
   begin
     fOnDroped(Self,PChar(GlobalLock(medium.hglobal)));
     GlobalUnLock(medium.hglobal);
   end;
   result := S_OK;
 end;
end;
procedure TTMyDrop.SetOnDroped(const Value: TDropEvent);
begin
 FOnDroped := Value;
end;
initialization
 TComObjectFactory.Create(ComServer, TTMyDrop, Class_TMyDrop,
   'TMyDrop', '', ciMultiInstance{, tmApartment});
end.

 OleInitialize(NIL);
 dd := TTMyDrop.Create;
 dd.OnDroped:=DoDroped;
 res1 := CoLockObjectExternal(dd, true, false);
 res := RegisterDragDrop(Handle, IDropTarget(dd));

procedure TForm1.DoDroped(Sender: TObject; Msg: Pchar);
begin
 ...//此处最好不要有太耗时的工作，因为被拖出的程序（比如说是浏览器）
    //要等待此事件结束
end;

 RevokeDragDrop(Handle);
 OleUninitialize;