请教高手关于：“利用Delphi编写IE扩展”

[delphi99]

我把“利用Delphi编写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的具体代码：

<贴子太长，源码部分付后>

代码很长，但是关键的是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 事件中编写代码访问服务器并转到正确的站点上去。

[delphi99]

那请教一下：这段代码为什么一点都不执行呢？
获取接口的方法不对吗？

[delphi99]

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 = '{41CA0320-1B63-11D8-8166-00055DE656A1}';

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

dopropertychange(dps.rgvarg^[pdispids^[0]].bstrval);

result := s_ok;

end;

[delphi99]

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('Software\Microsoft\Windows\CurrentVersion\explorer\Browser 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('Software\Microsoft\Windows\CurrentVersion\explorer\Browser 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.

[hongqi162]

你的代码执行到这里了吗？
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;

[delphi99]

一点都没有执行，我加了好几个断点，都没有反应。

[hongqi162]

这个程序只是一个框架，有很多内容都没有填写

[delphi99]

如何实现，请帮忙。最好给个实例。
email: [e-mail]

[hongqi162]

我现在也没有！

[delphi99]

真的没人解决吗？

[hyj122]

学习ING

[YHW]

检查internet选项/高级、启用第三方浏览器扩展是否打开

[YHW]

http://www.euromind.com/iedelphi/index.htm
这里资料比较全。

[delphi99]

回复： satanmonkey(撒旦) ：
我找不到这一项呀？

[bottom]

学习！

[delphi99]

请高手出招！！！

[delphi99]

真的没人解决吗？

[YHW]

估计你的IE是5.0
5。0用BHO有Bug
升级到5。5以上。