给 TWebBrowser.Document 定义事件
作者：互联网
给 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.
posted on
2010-03-04 18:28
万一
阅读(6747)
评论(21)
编辑
收藏
标签：begin,end,定义,TWebBrowser,Integer,var,const,Document,Memo1 来源： https://blog.51cto.com/u_14617575/2745745