文档章节

给 TWebBrowser.Document 定义事件

涂孟超
 涂孟超
发布于 2014/09/26 15:30
字数 898
阅读 13
收藏 0

(该代码来自国外网站, 给 "神奇的科比" 参考)

代码:
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.

 
 
 
 
 

 

 

  

本文转载自:http://www.cnblogs.com/del/archive/2010/03/04/1678550.html

涂孟超
粉丝 12
博文 2011
码字总数 14107
作品 0
深圳
程序员
私信 提问
FLEX程序设计--事件和事件机制--鼠标事件

事件类型 1.鼠标事件MouseEvent Code highlighting produced by Actipro CodeHighlighter (freeware) http://www.CodeHighlighter.com/ -->package { import flash.display.Sprite; import ......

小麋鹿666
2017/02/10
0
0
flex程序设计--事件和事件处理机制--时间事件

时间事件TimerEvent } var moveTimer:Timer=new Timer(50,250);moveTimer.addEventListener(TimerEvent.TIMER,onTimer);moveTimer.start(); } 版权说明 如果标题未标有等字则属于作者原创,欢......

小麋鹿666
2017/02/10
0
0
透过Keep-Alive实现防抖&节流组件

一、前言 在前一篇文章揭秘了的实现原理:彻底揭秘keep-alive原理,本文将模拟原理实现Vue的防抖和节流组件。本文介绍内容包含: 防抖/节流组件特性说明; 防抖/节流组件用法; 防抖/节流组件...

_安歌
05/05
0
0
也谈事件(Event)

最近园子里发表了一些讨论“事件(Event)”的文章,我也来凑个热闹,谈谈我对事件的一些粗浅的认识。本文不谈设计模式(观察者模式),只从运行时的角度来分析事件这个对象到底是个什么东西...

长平狐
2012/09/04
118
0
FLEX程序设计--事件和事件机制--键盘事件

键盘事件:KeyboardEvent } 版权说明 如果标题未标有等字则属于作者原创,欢迎转载,其版权归作者和博客园共有。 作 者:温景良 文章出处:http://wenjl520.cnblogs.com/ 或 http://www.cnblo...

小麋鹿666
2017/02/10
0
0

没有更多内容

加载失败,请刷新页面

加载更多

前端面试题汇总

一. HTML常见的兼容性 1.HTML5 标签在低版本浏览器不兼容 解决办法:使用html5shiv库,引入下列语句 <!--[if lte IE 8]> <script src="https://cdn.bootcss.com/html5shiv/r29/html5.js"></sc......

蓝小驴
31分钟前
7
0
OSChina 周四乱弹 —— 我气的脸都黑了!

Osc乱弹歌单(2019)请戳(这里) 【今日歌曲】 小小编辑推荐《Red Battle》- 高橋李依 / 豊崎愛生 《Red Battle》- 高橋李依 / 豊崎愛生 手机党少年们想听歌,请使劲儿戳(这里) @丶Lion ...

小小编辑
44分钟前
589
22
找OSG教程, B站就有

https://www.bilibili.com/video/av64849038?from=search&seid=11632913960900279653

洛克人杰洛
今天
5
0
学习记录(day07-Vue组件、自定义属性、自定义事件)

[TOC] 1.1.1什么是组件 一个vue文件就是一个组件 组件将html标签/css样式/对应JS打包成一个整体,也可以理解钻进一个具有样式和特效的自定义标签。 一、编写组件(提供方)<template> <di...

庭前云落
今天
5
0
使用Prometheus监控SpringBoot应用

通过之前的文章我们使用Prometheus监控了应用服务器node_exporter,数据库mysqld_exporter,今天我们来监控一下你的应用。(本文以SpringBoot 2.1.9.RELEASE 作为监控目标) 编码 添加依赖 使...

JAVA日知录
今天
9
0

没有更多内容

加载失败,请刷新页面

加载更多

返回顶部
顶部