就是如何使IE扩展组件可以响应事件。
    在自己的程序中使用过WebBrowser控件的朋友都知道,WebBrowser控件定义了诸如BeforeNavigate、DownloadComplete 等事件,我们可以通过编写事件处理代码实现对WebBrowser控件的操作。那么如何实现对IE的事件响应和处理呢?同建立IE面板一样。我们需要建立一个实现IObjectWithSite接口的COM组件,不同的是,我们还需要实现IDispatch接口,在IObjectWithSite接口的SetSite方法中获得IE的WebBrowser接口并建立自身与WebBrowser的连接,然后如果在IE的Webbrowser对象中发生什么事件的话,那么IE就会回调连接的IDispatch接口的Invoke方法。我们通过在Invoke方法中编写代码就可以获得IE事件了。这个利用的是COM编程的回调接口原理。
    下面我们首先来实现代码。点击Delphi菜单 File | New 。在 ActiveX 页面中选择Active Library ,然后点击 OK 按钮。然后用同样的方法建立一个COM Object。在COM Object Wizard 窗口中,将复选框 Included type library 去掉。然后在Class Name中输入IEHelper,在Implemented Interface 中输入:IDispatch;IObjectwithSite 。然后点击 OK 按钮建立一个COM组件
    保存工程,将工程保存为IEHelper.dpr,将Unit1保存为IEHelperUnit.pas。下面是IEHelperUnit.pas的具体代码:

unit iehelperunit;

interface

uses
WIndows, Comobj, ActiveX, SHDOCVW, MSHTML,Dialogs; type TIEHelperFactory = class(TComObjectFactory)
private
procedure AddKeys;
procedure RemoveKeys;
public
procedure UpdateRegistry(Register: Boolean); override;
end; TIEHelper = class(TComObject, IDispatch, IObjectWithSite)
public
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;
function SetSite(const pUnkSite: IUnknown): HResult; stdcall;
function GetSite(const riid: TIID; out site: IUnknown): HResult; stdcall;
private
IE: IWebbrowser2;
Cookie: Integer;
end; const
Class_IEHelper: TGUID = {3D898C55-74CC-4B7C-B5F1-45913F368388}; implementation uses ComServ, Registry, SysUtils; procedure DoStatusTextChange(const Text: WideString);
begin end; procedure DoProgressChange(Progress: Integer; ProgressMax: Integer);
begin end; procedure DoCommandStateChange(Command: Integer; Enable: WordBool);
begin end; procedure DoDownloadBegin;
begin end; procedure DoDownloadComplete;
begin end; procedure DoTitleChange(const Text: WideString);
begin end; procedure DoPropertyChange(const szProperty: WideString);
begin end; procedure DoBeforeNavigate2(const pDisp: IDispatch; var URL: OleVariant; var Flags: OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant; var Headers: OleVariant; var Cancel: WordBool);
begin
if URL<>http://www.applevb.com/then begin
Showmessage(你不可以浏览其它站点);
Cancel:=True;
URL:=http://www.applevb.com;
(pDisp as IWebbrowser2).Navigate2(URL,Flags,TargetFrameName,PostData,Headers);
end;
end; procedure DoNewWindow2(var ppDisp: IDispatch; var Cancel: WordBool);
begin end; procedure DoNavigateComplete2(const pDisp: IDispatch; var URL: OleVariant);
begin end; procedure DoDocumentComplete(const pDisp: IDispatch; var URL: OleVariant);
begin end; procedure DoOnQuit;
begin end; procedure DoOnVisible(Visible: WordBool);
begin end; procedure DoOnToolBar(ToolBar: WordBool);
begin end; procedure DoOnMenuBar(MenuBar: WordBool);
begin end; procedure DoOnStatusBar(StatusBar: WordBool);
begin end; procedure DoOnFullScreen(FullScreen: WordBool);
begin end; procedure DoOnTheaterMode(TheaterMode: WordBool);
begin end; procedure BuildPositionalDispIds(pDispIds: PDispIdList; const dps: TDispParams);
var
i: integer;
begin
Assert(pDispIds <> nil);
for i := to dps.cArgs - do
pDispIds^[i] := dps.cArgs - - i;
if (dps.cNamedArgs <= ) then Exit;
for i := to dps.cNamedArgs - do
pDispIds^[dps.rgdispidNamedArgs^[i]] := i;
end; function TIEHelper.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
type
POleVariant = ^OleVariant;
var
dps: TDispParams absolute Params;
bHasParams: boolean;
pDispIds: PDispIdList;
iDispIdsSize: integer;
begin
Result := DISP_E_MEMBERNOTFOUND;
pDispIds := nil;
iDispIdsSize := ;
bHasParams := (dps.cArgs > );
if (bHasParams) then
begin
iDispIdsSize := dps.cArgs * SizeOf(TDispId);
GetMem(pDispIds, iDispIdsSize);
end;
try
if (bHasParams) then BuildPositionalDispIds(pDispIds, dps);
case DispId of
:
begin
DoStatusTextChange(dps.rgvarg^[pDispIds^[]].bstrval);
Result := S_OK;
end;
:
begin
DoProgressChange(dps.rgvarg^[pDispIds^[]].lval, dps.rgvarg^[pDispIds^[]].lval);
Result := S_OK;
end;
:
begin
DoCommandStateChange(dps.rgvarg^[pDispIds^[]].lval, dps.rgvarg^[pDispIds^[]].vbool);
Result := S_OK;
end;
:
begin
DoDownloadBegin();
Result := S_OK;
end;
:
begin
DoDownloadComplete();
Result := S_OK;
end;
:
begin
DoTitleChange(dps.rgvarg^[pDispIds^[]].bstrval);
Result := S_OK;
end;
:
begin
DoPrtype
POleVariant = ^OleVariant;
var
dps: TDispParams absolute Params;
bHasParams: boolean;
pDispIds: PDispIdList;
iDispIdsSize: integer;
begin
Result := DISP_E_MEMBERNOTFOUND;
pDispIds := nil;
iDispIdsSize := ;
bHasParams := (dps.cArgs > );
if (bHasParams) then
begin
iDispIdsSize := dps.cArgs * SizeOf(TDispId);
GetMem(pDispIds, iDispIdsSize);
end;
try
if (bHasParams) then BuildPositionalDispIds(pDispIds, dps);
case DispId of
:
begin
DoStatusTextChange(dps.rgvarg^[pDispIds^[]].bstrval);
Result := S_OK;
end;
:
begin
DoProgressChange(dps.rgvarg^[pDispIds^[]].lval, dps.rgvarg^[pDispIds^[]].lval);
Result := S_OK;
end;
:
begin
DoCommandStateChange(dps.rgvarg^[pDispIds^[]].lval, dps.rgvarg^[pDispIds^[]].vbool);
Result := S_OK;
end;
:
begin
DoDownloadBegin();
Result := S_OK;
end;
:
begin
DoDownloadComplete();
Result := S_OK;
end;
:
begin
DoTitleChange(dps.rgvarg^[pDispIds^[]].bstrval);
Result := S_OK;
end;
:
begin
DoPropertyChange(dps.rgvarg^[pDispIds^[]].bstrval);
Result := S_OK;
end;
:
begin
DoBeforeNavigate2(IDispatch(dps.rgvarg^[pDispIds^[]].dispval), POleVariant(dps.rgvarg^[pDispIds^[]].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[]].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[]].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[]].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[]].pvarval)^, dps.rgvarg^[pDispIds^[]].pbool^);
Result := S_OK;
end;
:
begin
DoNewWindow2(IDispatch(dps.rgvarg^[pDispIds^[]].pdispval^), dps.rgvarg^[pDispIds^[]].pbool^);
Result := S_OK;
end;
:
begin
DoNavigateComplete2(IDispatch(dps.rgvarg^[pDispIds^[]].dispval), POleVariant(dps.rgvarg^[pDispIds^[]].pvarval)^);
Result := S_OK;
end;
:
begin
DoDocumentComplete(IDispatch(dps.rgvarg^[pDispIds^[]].dispval), POleVariant(dps.rgvarg^[pDispIds^[]].pvarval)^);
Result := S_OK;
end;
:
begin
DoOnQuit();
Result := S_OK;
end;
:
begin
DoOnVisible(dps.rgvarg^[pDispIds^[]].vbool);
Result := S_OK;
end;
:
begin
DoOnToolBar(dps.rgvarg^[pDispIds^[]].vbool);
Result := S_OK;
end;
:
begin
DoOnMenuBar(dps.rgvarg^[pDispIds^[]].vbool);
Result := S_OK;
end;
:
begin
DoOnStatusBar(dps.rgvarg^[pDispIds^[]].vbool);
Result := S_OK;
end;
:
begin
DoOnFullScreen(dps.rgvarg^[pDispIds^[]].vbool);
Result := S_OK;
end;
:
begin
DoOnTheaterMode(dps.rgvarg^[pDispIds^[]].vbool);
Result := S_OK;
end;
end;
finally
if (bHasParams) then FreeMem(pDispIds, iDispIdsSize);
end;
end; function TIEHelper.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
Result := E_NOTIMPL;
end; function TIEHelper.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin
Result := E_NOTIMPL;
pointer(TypeInfo) := nil;
end; function TIEHelper.GetTypeInfoCount(out Count: Integer): HResult;
begin
Result := E_NOTIMPL;
Count := ;
end; function TIEHelper.GetSite(const riid: TIID; out site: IUnknown): HResult;
begin
// Result := S_OK;
if Assigned(IE) then result:=IE.QueryInterface(riid, site)
else
Result:= E_FAIL;
end; function TIEHelper.SetSite(const pUnkSite: IUnknown): HResult;
var
cmdTarget: IOleCommandTarget;
Sp: IServiceProvider;
CPC: IConnectionPointContainer;
CP: ICOnnectionPoint;
begin
if Assigned(pUnkSite) then begin
cmdTarget := pUnkSite as IOleCommandTarget;
Sp := CmdTarget as IServiceProvider; if Assigned(Sp)then
Sp.QueryService(IWebbrowserApp, IWebbrowser2, IE);
if Assigned(IE) then begin
IE.QueryInterface(IConnectionPointContainer, CPC);
CPC.FindConnectionPoint(DWEBbrowserEvents2, CP);
CP.Advise(Self, Cookie)
end;
end;
Result := S_OK;
end; procedure TIEHelperFactory.AddKeys;
var S: string;
begin
S := GUIDToString(CLASS_IEHelper);
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
if OpenKey(SoftwareMicrosoftWindowsCurrentVersionexplorerBrowser Helper Objects + S, TRUE)
then CloseKey;
finally
free;
end;
end; procedure TIEHelperFactory.RemoveKeys;
var S: string;
begin
S := GUIDToString(CLASS_IEHelper);
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
DeleteKey(SoftwareMicrosoftWindowsCurrentVersionexplorerBrowser Helper Objects + S);
finally
free;
end;
end; procedure TIEHelperFactory.UpdateRegistry(Register: Boolean);
begin
inherited UpdateRegistry(Register);
if Register then AddKeys else RemoveKeys;
end; initialization
TIEHelperFactory.Create(ComServer, TIEHelper, Class_IEHelper,
IEHelper, , ciMultiInstance, tmApartment);
end.

代码很长,但是关键的是TIEHelper.SetSite方法以及TIEHelper.Invoke方法。在TIEHelper.SetSite方法中注意以下语句:
     if Assigned(Sp)then
       Sp.QueryService(IWebbrowserApp, IWebbrowser2, IE);
     if Assigned(IE) then begin
       IE.QueryInterface(IConnectionPointContainer, CPC);
       CPC.FindConnectionPoint(DWEBbrowserEvents2, CP);
       CP.Advise(Self, Cookie)
上面的语句作用是,首先获得IE的Webbrowser接口,然后寻找到连接点。并通过Advise方法建立COM自身与连接点的连接。
   当连接建立成功后,IE在有事件引发后,会调用连接到自身的IDispatch接口对象的Invoke方法。不同的事件对应不同的DispID编码,我们可以在程序中判断DispID并做相应的处理。在上面的程序中,我们只处理了BeforeNavigate2 事件,处理函数是DoBeforeNavigate2,在该函数中,如果浏览的站点不是http://www.applevb.com/的话,程序会提示:你不可以浏览其它站点并强行转到http://www.applevb.com
   很多的软件,象“护花使者”以及“3721”一类的中文网址”都是利用上面的原理来实现对IE浏览器事件响应的,例如3721,当用户输入一个中文词并浏览时,COM组件可以在BeforeNavigate2 事件中编写代码访问服务器并转到正确的站点上去。

利用Delphi编写IE扩展的更多相关文章

  1. 利用Delphi编写Socket通信程序

    一.Delphi与Socket 计算机网络是由一系列网络通信协议组成的,其中的核心协议是传输层的TCP/IP和UDP协议.TCP是面向连接的,通信双方保持一条通路,好比目前的电话线,使用telnet登 ...

  2. Delphi编写Shell扩展

    用delphi创建一个外壳扩展(Shell Extension)程序的基本步骤如下: (1) 创建一个 ActiveX Library 工程,命名为“CloudUpload“(2) 创建一个新的自动化 ...

  3. Delphi 编写ActiveX控件(OCX控件)的知识和样例(有详细步骤)

    一.ActiveX应用情况简介: ActiveX控件也就是一般所说的OCX控件,它是 ActiveX技术的一部分.ActiveX是微软公司推出的基于组件对象模型COM的技术,包括对Windows 32 ...

  4. 转 : 用Delphi编写安装程序

    http://www.okbase.net/doc/details/931  还没有亲自验证过,仅收藏 当你完成一个应用软件的开发后,那么你还需要为该软件做一个规范化的安装程序,这是程序设计的最后一步 ...

  5. 利用Delphi监视注册表的变化

    转帖:利用Delphi监视注册表的变化 2009-12-23 11:53:51 分类: 利用Delphi监视注册表的变化       我们在编写软件的时候,常常需要把一些信息保存到系统的注册表中.如果 ...

  6. 品味性能之道<九>:利用Loadrunner编写socket性能测试脚本简述

            一.概述         Loadrunner拥有极为丰富的工具箱,供予我们制造出各种奇妙魔法的能力.其中就有此次要讨论的socket套接字操作.     二.socket概述     ...

  7. 一步步入门编写PHP扩展

    1.写在最前 随着互联网飞速发展,lamp架构的流行,php支持的扩展也越来越多,这样直接促进了php的发展. 但是php也有脚本语言不可避免的问题,性能比例如C等编译型语言相差甚多,所以在考虑性能问 ...

  8. Delphi编写WebService体会

    源:Delphi编写WebService体会 Dispatch: 派遣,分派 Invoke: 调用 Invokable: 可调用接口 TReomtable: WebService中自定义类都是继承自该 ...

  9. 利用Delphi的File Of Type创建并管理属于你自己的数据库

    http://www.360doc.com/content/16/1128/19/28222077_610249962.shtml 利用Delphi的File Of Type创建并管理属于你自己的数据 ...

随机推荐

  1. redhat5 设置静态ip

    Last login: Sat Oct 14 16:19:13 2017 # 进入ip凭证文件设置地方 [root@oracle ~]# cd /etc/sysconfig/network-scrip ...

  2. LeetCode(39):组合总和

    Medium! 题目描述: 给定一个无重复元素的数组 candidates 和一个目标数 target ,找出 candidates 中所有可以使数字和为 target 的组合. candidates ...

  3. 【gearman】学习笔记

    学习资料:http://gearman.org/manual/ 1.Gearman是跨语言的,client和worker可以用不同的语言来实现 2.client与job server之间的交互称为ta ...

  4. 2018-2019 2 20165203 《网络对抗技术》Exp5 MSF基础

    2018-2019 2 20165203 <网络对抗技术>Exp5 MSF基础 实验内容 本实践目标是掌握metasploit的基本应用方式,重点常用的三种攻击方式的思路.具体需要完成: ...

  5. Android 使用 SVG 矢量图

    android svg矢量图 可能包含的操作有: SVG图还包括改变颜色,透明度,大小,矩阵操作(平移.旋转.缩放),selector, (图标,背景,按钮),动画,等 setTint(int Col ...

  6. openstack学习-Horizon安装(八)

    一.安装Horizon [root@linux-node2 ~]# yum install -y openstack-dashboard 二.Horizon配置 [root@linux-node2 ~ ...

  7. P1865 A % B Problem 素数筛

    题目描述 区间质数个数 输入输出格式 输入格式: 一行两个整数 询问次数n,范围m 接下来n行,每行两个整数 l,r 表示区间 输出格式: 对于每次询问输出个数 t,如l或r∉[1,m]输出 Cros ...

  8. 6-8 树 uva548

    read 的方式值得学习 当不知道每一行有多少个输入的时候 getline  在弄成stringstream!一个一个处理 用built递归的方式化大为小进行建立树 dfs 遍历整个树来求最值 变量的 ...

  9. Unity3d 之 理解Gameobject ,gameObject,Transform,transform的区别和关联

    Gameobject是一个类型,所有的游戏物件都是这个类型的对象. gameobject是一个对象, 就跟java里面的this一样, 指的是这个脚本所附着的游戏物件 public class Sho ...

  10. 不一样的go语言-一样的语法

    前言   上一篇入门篇算是初识庐山真面目,我们知道了一个go程序的构成,在这里总结一下. //包名 package //导入包 import "fmt" //main方法,程序入口 ...