Delphi中获取TWebBrowser中鼠标移动到超链接的URL

unit  Unit1;

interface

uses
   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
   Dialogs, OleCtrls, SHDocVw, MSHTML, ActiveX, StdCtrls;

type
   TObjectProcedure =  procedure   of   object ;

   TEventObject =  class (TInterfacedObject, IDispatch)
    private
     FOnEvent: TObjectProcedure;
   protected
      function  GetTypeInfoCount(out Count: Integer): HResult; stdcall;
      function  GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
      function  GetIDsOfNames( const  IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
      function  Invoke(DispID: Integer;  const  IID: TGUID; LocaleID: Integer; Flags: Word;  var  Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
    public
      constructor  Create( const  OnEvent: TObjectProcedure) ;
      property  OnEvent: TObjectProcedure read FOnEvent write FOnEvent;
    end ;

   TForm1 =  class (TForm)
     WebBrowser1: TWebBrowser;
     elementInfo: TMemo;
      procedure  WebBrowser1BeforeNavigate2(ASender: TObject;  const  pDisp: IDispatch;  var  URL, Flags, TargetFrameName, PostData, Headers: OleVariant;  var  Cancel: WordBool) ;
      procedure  WebBrowser1DocumentComplete(ASender: TObject;  const  pDisp: IDispatch;  var  URL: OleVariant) ;
      procedure  FormCreate(Sender: TObject) ;
    private
      procedure  Document_OnMouseOver;
    public
     {  Public  declarations }
    end ;

var
   Form1: TForm1;

   htmlDoc : IHTMLDocument2;

implementation

{$R *.dfm}

procedure  TForm1.Document_OnMouseOver;
var
   element : IHTMLElement;
begin
    if  htmlDoc =  nil   then  Exit;

   element := htmlDoc.parentWindow.event.srcElement;

   elementInfo.Clear;

    if  LowerCase(element.tagName) = 'a'  then
    begin
     elementInfo.Lines.Add('LINK info...') ;
     elementInfo.Lines.Add(Format('HREF : %s',[element.getAttribute('href',0)])) ;
    end
    else   if  LowerCase(element.tagName) = 'img'  then
    begin
     elementInfo.Lines.Add('IMAGE info...') ;
     elementInfo.Lines.Add(Format('SRC : %s',[element.getAttribute('src',0)])) ;
    end
    else
    begin
     elementInfo.Lines.Add(Format('TAG : %s',[element.tagName])) ;
    end ;
end ;  (*Document_OnMouseOver*)


procedure  TForm1.FormCreate(Sender: TObject) ;
begin
   WebBrowser1.Navigate('http://delphi.about.com') ;

   elementInfo.Clear;
   elementInfo.Lines.Add('Move your mouse over the document...') ;
end ;  (*FormCreate*)

procedure  TForm1.WebBrowser1BeforeNavigate2(ASender: TObject;  const  pDisp: IDispatch;  var  URL, Flags, TargetFrameName, PostData, Headers: OleVariant;  var  Cancel: WordBool) ;
begin
   htmlDoc :=  nil ;
end ; (*WebBrowser1BeforeNavigate2*)

procedure  TForm1.WebBrowser1DocumentComplete(ASender: TObject;  const  pDisp: IDispatch;  var  URL: OleVariant) ;
begin
    if  Assigned(WebBrowser1.Document)  then
    begin
     htmlDoc := WebBrowser1.Document  as  IHTMLDocument2;

     htmlDoc.onmouseover := (TEventObject.Create(Document_OnMouseOver)  as  IDispatch) ;
    end ;
end ;  (*WebBrowser1DocumentComplete*)


{ TEventObject }

constructor  TEventObject.Create( const  OnEvent: TObjectProcedure) ;
begin
    inherited  Create;
   FOnEvent := OnEvent;
end ;

function  TEventObject.GetIDsOfNames( const  IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
   Result := E_NOTIMPL;
end ;

function  TEventObject.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
   Result := E_NOTIMPL;
end ;

function  TEventObject.GetTypeInfoCount(out Count: Integer): HResult;
begin
   Result := E_NOTIMPL;
end ;

function  TEventObject.Invoke(DispID: Integer;  const  IID: TGUID; LocaleID: Integer; Flags: Word;  var  Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
begin
    if  (DispID = DISPID_VALUE)  then
    begin
      if  Assigned(FOnEvent)  then  FOnEvent;
     Result := S_OK;
    end
    else  Result := E_NOTIMPL;
end ;

end .