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

Here's how to implement event sinking for a document displayed by the TWebBrowser component - and get the info of a HTML element below the mouse.

TWebBrowser Document Event Sinking Example

Drop a TWebBrowser ("WebBrowser1") on a Form ("Form1"). Add a TMemo ("elementInfo")...

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.

• 1
• 2