给 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.