給 TWebBrowser.Document 定義事件

　(該代碼來自國外網站, 給 "神奇的科比" 參考)

　　代碼:

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;　
　　　Memo1:　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;　
　　Memo1.Clear;　
　　if　LowerCase(element.tagName)　=　'a'　then　
　　begin　
　　　Memo1.Lines.Add('LINK　info...');　
　　　Memo1.Lines.Add(Format('HREF　:　%s',　[element.getAttribute('href',　0)]));　
　　end　
　　else　if　LowerCase(element.tagName)　=　'img'　then　
　　begin　
　　　Memo1.Lines.Add('IMAGE　info...');　
　　　Memo1.Lines.Add(Format('SRC　:　%s',　[element.getAttribute('src',　0)]));　
　　end　
　　else　
　　begin　
　　　Memo1.Lines.Add(Format('TAG　:　%s',　[element.tagName]));　
　　end;　
　end;　(*　Document_OnMouSEOver　*)　
　
　procedure　TForm1.FormCreate(Sender:　TObject);　
　begin　
　　WebBrowser1.Navigate('http://del.cnblogs.com');　
　　Memo1.Clear;　
　　Memo1.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.　

　窗體:

object　Form1:　TForm1　
　Left　=　0　
　Top　=　0　
　Caption　=　'Form1'　
　ClIEntHeight　=　375　
　ClIEntWidth　=　643　
　Color　=　clBtnFace　
　Font.Charset　=　DEFAULT_CHARSET　
　Font.Color　=　clWindowText　
　Font.Height　=　-11　
　Font.Name　=　'Tahoma'　
　Font.Style　=　[]　
　OldCreateOrder　=　False　
　OnCreate　=　FormCreate　
　PixelsPerInch　=　96　
　TextHeight　=　13　
　object　WebBrowser1:　TWebBrowser　
　　Left　=　0　
　　Top　=　73　
　　Width　=　643　
　　Height　=　302　
　　Align　=　alClIEnt　
　　TabOrder　=　0　
　　OnBeforeNavigate2　=　WebBrowser1BeforeNavigate2　
　　OnDocumentComplete　=　WebBrowser1DocumentComplete　
　　ExplicitLeft　=　264　
　　ExplicitTop　=　200　
　　ExplicitWidth　=　300　
　　ExplicitHeight　=　150　
　　ControlData　=　{　
　　　4C00000075420000361F00000000000000000000000000000000000000000000　
　　　000000004C000000000000000000000001000000E0D057007335CF11AE690800　
　　　2B2E126208000000000000004C0000000114020000000000C000000000000046　
　　　8000000000000000000000000000000000000000000000000000000000000000　
　　　00000000000000000100000000000000000000000000000000000000}　
　end　
　object　Memo1:　TMemo　
　　Left　=　0　
　　Top　=　0　
　　Width　=　643　
　　Height　=　73　
　　Align　=　alTop　
　　Lines.Strings　=　(　
　　　'Memo1')　
　　TabOrder　=　1　
　end　
end　

　給 "神奇的科比" 改的識別第一個框架的代碼:

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;　
　　　Memo1:　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;　
　　Memo1.Clear;　
　　if　LowerCase(element.tagName)　=　'a'　then　
　　begin　
　　　Memo1.Lines.Add('LINK　info...');　
　　　Memo1.Lines.Add(Format('HREF　:　%s',　[element.getAttribute('href',　0)]));　
　　end　
　　else　if　LowerCase(element.tagName)　=　'img'　then　
　　begin　
　　　Memo1.Lines.Add('IMAGE　info...');　
　　　Memo1.Lines.Add(Format('SRC　:　%s',　[element.getAttribute('src',　0)]));　
　　end　
　　else　
　　begin　
　　　Memo1.Lines.Add(Format('TAG　:　%s',　[element.tagName]));　
　　end;　
　end;　(*　Document_OnMouSEOver　*)　
　
　procedure　TForm1.FormCreate(Sender:　TObject);　
　begin　
　　WebBrowser1.Navigate('http://passport.csdn.Net/UserLogin.ASPx');　
　　Memo1.Clear;　
　　Memo1.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;　
　　　if　HtmlDoc.frames.length　>　0　then　
　　　begin　
　　　　htmlDoc　:=　(IDispatch(htmlDoc.frames.item(0))　as　IHtmlWindow2).Document;　
　　　end;　
　　　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.