Define events for twebbrowser. Document

(This code is from a foreign website and can be used as a reference for "Magic Kobe)

Code:

unit Unit1;interfaceuses   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.
 

Form:

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  endend
 

Code for identifying the first framework for "Magic Kobe:

unit Unit1;interfaceuses   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.