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