利用Delphi编写IE扩展

于 2019-07-27 05:15:10 发布
阅读量56 收藏
点赞数
原文链接：http://www.cnblogs.com/MaxWoods/p/4012297.html
版权

就是如何使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 := 0 to dps.cArgs - 1 do
    pDispIds^[i] := dps.cArgs - 1 - i;
  if (dps.cNamedArgs <= 0) then Exit;
  for i := 0 to dps.cNamedArgs - 1 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 := 0;
  bHasParams := (dps.cArgs > 0);
  if (bHasParams) then
  begin
    iDispIdsSize := dps.cArgs * SizeOf(TDispId);
    GetMem(pDispIds, iDispIdsSize);
  end;
  try
    if (bHasParams) then BuildPositionalDispIds(pDispIds, dps);
    case DispId of
      102:
        begin
          DoStatusTextChange(dps.rgvarg^[pDispIds^[0]].bstrval);
          Result := S_OK;
        end;
      108:
        begin
          DoProgressChange(dps.rgvarg^[pDispIds^[0]].lval, dps.rgvarg^[pDispIds^[1]].lval);
          Result := S_OK;
        end;
      105:
        begin
          DoCommandStateChange(dps.rgvarg^[pDispIds^[0]].lval, dps.rgvarg^[pDispIds^[1]].vbool);
          Result := S_OK;
        end;
      106:
        begin
          DoDownloadBegin();
          Result := S_OK;
        end;
      104:
        begin
          DoDownloadComplete();
          Result := S_OK;
        end;
      113:
        begin
          DoTitleChange(dps.rgvarg^[pDispIds^[0]].bstrval);
          Result := S_OK;
        end;
      112:
        begin
          DoPrtype
 POleVariant = ^OleVariant;
var
 dps: TDispParams absolute Params;
 bHasParams: boolean;
 pDispIds: PDispIdList;
 iDispIdsSize: integer;
begin
 Result := DISP_E_MEMBERNOTFOUND;
 pDispIds := nil;
 iDispIdsSize := 0;
 bHasParams := (dps.cArgs > 0);
 if (bHasParams) then
 begin
   iDispIdsSize := dps.cArgs * SizeOf(TDispId);
   GetMem(pDispIds, iDispIdsSize);
 end;
 try
   if (bHasParams) then BuildPositionalDispIds(pDispIds, dps);
   case DispId of
     102:
       begin
         DoStatusTextChange(dps.rgvarg^[pDispIds^[0]].bstrval);
         Result := S_OK;
       end;
     108:
       begin
         DoProgressChange(dps.rgvarg^[pDispIds^[0]].lval, dps.rgvarg^[pDispIds^[1]].lval);
         Result := S_OK;
       end;
     105:
       begin
         DoCommandStateChange(dps.rgvarg^[pDispIds^[0]].lval, dps.rgvarg^[pDispIds^[1]].vbool);
         Result := S_OK;
       end;
     106:
       begin
         DoDownloadBegin();
         Result := S_OK;
       end;
     104:
       begin
         DoDownloadComplete();
         Result := S_OK;
       end;
     113:
       begin
         DoTitleChange(dps.rgvarg^[pDispIds^[0]].bstrval);
         Result := S_OK;
       end;
     112:
       begin
         DoPropertyChange(dps.rgvarg^[pDispIds^[0]].bstrval);
         Result := S_OK;
       end;
     250:
       begin
         DoBeforeNavigate2(IDispatch(dps.rgvarg^[pDispIds^[0]].dispval), POleVariant(dps.rgvarg^[pDispIds^[1]].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[2]].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[3]].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[4]].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[5]].pvarval)^, dps.rgvarg^[pDispIds^[6]].pbool^);
         Result := S_OK;
       end;
     251:
       begin
         DoNewWindow2(IDispatch(dps.rgvarg^[pDispIds^[0]].pdispval^), dps.rgvarg^[pDispIds^[1]].pbool^);
         Result := S_OK;
       end;
     252:
       begin
         DoNavigateComplete2(IDispatch(dps.rgvarg^[pDispIds^[0]].dispval), POleVariant(dps.rgvarg^[pDispIds^[1]].pvarval)^);
         Result := S_OK;
       end;
     259:
       begin
         DoDocumentComplete(IDispatch(dps.rgvarg^[pDispIds^[0]].dispval), POleVariant(dps.rgvarg^[pDispIds^[1]].pvarval)^);
         Result := S_OK;
       end;
     253:
       begin
         DoOnQuit();
         Result := S_OK;
       end;
     254:
       begin
         DoOnVisible(dps.rgvarg^[pDispIds^[0]].vbool);
         Result := S_OK;
       end;
     255:
       begin
         DoOnToolBar(dps.rgvarg^[pDispIds^[0]].vbool);
         Result := S_OK;
       end;
     256:
       begin
         DoOnMenuBar(dps.rgvarg^[pDispIds^[0]].vbool);
         Result := S_OK;
       end;
     257:
       begin
         DoOnStatusBar(dps.rgvarg^[pDispIds^[0]].vbool);
         Result := S_OK;
       end;
     258:
       begin
         DoOnFullScreen(dps.rgvarg^[pDispIds^[0]].vbool);
         Result := S_OK;
       end;
     260:
       begin
         DoOnTheaterMode(dps.rgvarg^[pDispIds^[0]].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 := 0;
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 事件中编写代码访问服务器并转到正确的站点上去。

 

转载于:https://www.cnblogs.com/MaxWoods/p/4012297.html

weixin_30716141
关注
delphi编写的IE浏览器又加了不少功能
08-31
标题中的“delphi编写的IE浏览器又加了不少功能”表明我们正在讨论一个使用Delphi编程语言开发的Internet Explorer（IE）浏览器的定制版本。Delphi是Embarcadero Technologies公司开发的一种面向对象的 Pascal 编程...
[Delphi] 利用DELPHI编写IE扩展
delphi99的专栏
09-23 772
在自己的程序中使用过WebBrowser控件的朋友都知道，WebBrowser控件定义了诸如BeforeNavigate、DownloadComplete 等事件，我们可以通过编写事件处理代码实现对WebBrowser控件的操作。那么如何实现对IE的事件响应和处理呢？同建立IE面
DelphiIE插件开发
JUST DO IT.
03-12 1683
看这篇文章就差不多了：Delphi 开发ActiveX控件(非ActiveForm) 另外要注意的是Delphi7 web deploy一次之后菜单就变灰了。Delphi6没这个问题。 html文件中的cab版本号一定要和dll版本号一致，否则总是提示安装的。
IE菜单扩展
08-28 136
介绍 向IE中添加的自定义菜单，可以被用来执行可执行文件，脚本语言和COM对象的方法，对于前两种执行方式，相对比较简单，只需要对注册表进行编程就可以了，但是能够执行的功能非常有限，而使用COM组件扩展IE菜单则相对复杂，但是能够执行的功能也相对是最强大的，所以下面我就主要介绍基于COM的菜单扩展方式，还要注意的一点是只有IE5及以后的版本才支持菜单的扩展。 创建COM组件 对于一个IE菜...
使用Delphi创建IE扩展：实现事件响应
在本文中，我们将探讨如何利用Delphi编写IE扩展，以便于自定义IE浏览器的行为或增加功能。 首先，我们需要了解WebBrowser控件，这是一个内置于Delphi中的组件，它可以嵌入到应用程序中，模拟Internet Explorer...
delphi-bho.rar_BHO_bho delphi_delphi IE_delphi bho_delphi ie插件
09-20
在描述中提到的"DELPHI开发IE的BHO插件，阻断式开发实例讲解"，暗示了这个压缩包可能包含一个具体的BHO开发案例，其中可能会讲解如何利用Delphi的事件处理机制来实现对浏览器行为的阻断或拦截，比如阻止某些网页元素...
IE Toolbar的例子.zip_IE_IE toolbar_Toolbar_delphi toolbar_ie delphi
09-21
- 测试和调试：如何在实际的IE环境中测试工具栏，以及如何利用Delphi的调试器解决问题。 通过学习这个项目，开发者可以提升在Delphi中创建自定义工具栏的能力，了解如何与已有的应用程序（如IE浏览器）进行集成，这...
利用Delphi编写IE扩展 (转)
ciya3282的博客
10-02 97
利用Delphi编写IE扩展 (转)[@more@]就是如何使IE扩展组件可以响应事件。 在自己的程序中使用过webBrowser控件的朋友都知道，WebBrowser控件定义了诸如BeforeNavigate、DOWNLOA...
Delphi开发IEActiveX插件封装外部DLL完整示例
03-02
完整示例，原创源码，转载请注明出处，我的资源都是免费的。 将外部DLL文件编译入ActiveX资源（res），运行时再将DLL释放到指定位置，供ActiveX调用，特别注意：DLL或EXE不能加壳，编译的不要做任何改动，否则IE环境下无法加载。 内附完整JAVASCRIPT与ActiveX互通消息的HTML文件。
delphi 通过IE插件限制打开有关键字网站
08-06
delphi 通过IE插件限制打开有关键字网站，并且自动跳转到制定页面，可以有效屏蔽网站
delphi开发的 BHO ie插件
05-17
delphi开发的 BHO ie插件,请阅！
Delphi封装DLL到IE OCX控件
02-29
将DLL做成RES编译进工程，运行时释放资料保存到系统TEMP目录下调用，WIN32模式下调用一切正常，用Delphi自带的WebBrowser调用也正常，但在IE下调用DLL提示无法加载，望高手解决，谢谢。
使用Delphi开发IE按钮扩展
一个被知识诅咒的人
10-02 626
<br />介绍<br />除了可以向IE中添加自定义菜单外，我们还可以向IE的工具条上添加自定义的按钮。自定义按钮同自定义菜单COM扩展的实现几乎一样， 除了在注册时需要添加的注册表项不同。 注意：同菜单扩展一样，自定义的按钮扩展也必须是IE5及以后的版本才支持。<br /> <br />创建COM组件<br /> <br />下面我们要创建的IE工具条按钮要稍微复杂一些，当点击时，不再只是显示一个简单的对话框了，而是让当前浏览器浏览我的个人网站 http://hubdog.csdn.net。同前一节一样
利用DELPHI编写IE扩展
桂林哈秋 - 我想学编程
01-01 1313
在自己的程序中使用过WebBrowser控件的朋友都知道，WebBrowser控件定义了诸如BeforeNavigate、DownloadComplete 等事件，我们可以通过编写事件处理代码实现对WebBrowser控件的操作。那么如何实现对IE的事件响应和处理呢？同建立IE面板一样。我们需要建立一个实现IObjectWithSite接口的COM组件，不同的是，我们还需要实现IDispatch接
[Delphi] 使用Delphi开发IE按钮扩展
delphi99的专栏
10-14 689
使用Delphi开发IE按钮扩展     介绍 除了可以向IE中添加自定义菜单外，我们还可以向IE的工具条上添加自定义的按钮。自定义按钮同自定义菜单COM扩展的实现几乎一样， 除了在注册时需要添加的注册表项不同。 注意：同菜单扩展一样，自定义的按钮扩展也必须是IE5及以后
制作IE扩展
jianguang_qq的专栏
06-20 194
上周终于把有我全权负责的项目《电信本地网ITSM支撑平台》给验收了，验收完后顺便陪老师一起去做一个新项目的可行性分析。 由于项目需要用到IE插件，故学习下 1、写注册表 “注册.cmd” reg add "HKEY_CURRENT_USER\SOFTWARE\microsoft\Internet Explorer\MenuExt\张剑光测试工具" /v "" /t "REG_SZ" /d "...
评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值