Get the Url of a Hyperlink when the Mouse moves Over a TWebBrowser Document

The TWebBrowser Delphi component provides access to the Web browser functionality from your Delphi applications.

In most situations you use the TWebBrowser to display HTML documents to the user - thus creating your own version of the (Internet Explorer) Web browser. Note that the TWebBrowser can also display Word documents, for example.

A very nice feature of a Browser is to display link information, for example, in the status bar, when the mouse hovers over a link in a document.

The TWebBrowser does not expose an event like "OnMouseMove". Even if such an event would exist it would be fired for the TWebBrowser component - NOT for the document being displayed inside the TWebBrowser.

In order to provide such information (and much more, as you will see in a moment) in your Delphi application using the TWebBrowser component, a technique called "events sinking" must be implemeted.

WebBrowser Event Sink

To get the "href" attribute (link) of an "a" tag inside a document, while the mouse hovers over a document, you need to react on the "onmousemove" event of the IHTMLDocument2.

Here are the steps to sink events for the currently loaded document:

1. Sink the WebBrowser control's events in the DocumentComplete event raised by the TWebBrowser. This event is fired when the document is fully loaded into the Web Browser.
2. Inside DocumentComplete, retrieve the WebBrowser's document object and sink the HtmlDocumentEvents interface.
3. Handle the event you are interested in.
4. Clear the sink in the in BeforeNavigate2 - that is when the new document is loaded in the Web Browser.

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.