大家帮我分析一下，对IE的控制为什么会导致错误？（在线等候）(20分)

我写了一段代码，目的是消除弹出窗口，代码如下：
clearads.dpr
library clearads;

uses
ComServ,
clearads_TLB in 'clearads_TLB.pas',
cleanad in 'cleanad.pas';

exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer;

{$R *.TLB}

{$R *.RES}

begin
end.

cleanad.pas

unit cleanad;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
Windows, ActiveX, ComObj, SHDOCVW, MSHTML;

type
TcleanadFactory = class(TComObjectFactory)

private
procedure AddKeys;
procedure RemoveKeys;
public
procedure UpdateRegistry(Register: Boolean); override;
end;
Tcleanad = 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_cleanad: TGUID = '{7AE2268B-DA18-4084-A410-786BD8B1BE97}';

implementation

uses ComServ, Registry, SysUtils;

procedure dowindowclosing(const pDisp: IDispatch; var ischildwindow:wordbool;var cancel:wordbool);
//这里我原想对script语句产生的窗口进行自动关闭，但是没有效果
begin
with (pdisp as iwebbrowser2) do
begin
if ischildwindow then
cancel:=true
else
cancel:=false;
end;
end;
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);
//在dowindowclosing中没有效果，所以在这里尝试关闭没有toolbar的窗口
begin
if (pdisp as iwebbrowser2).ToolBar=0 then begin
(pdisp as iwebbrowser2).Stop;
cancel:=true;
(pdisp as iwebbrowser2).Quit;
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^ := dps.cArgs - 1 - i;
if (dps.cNamedArgs <= 0) then Exit;
for i := 0 to dps.cNamedArgs - 1 do
pDispIds^[dps.rgdispidNamedArgs^] := i;
end;

function Tcleanad.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;
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;
263:
begin
dowindowclosing(IDispatch(dps.rgvarg^[pDispIds^[0]].pdispval^),dps.rgvarg^[pDispIds^[1]].vbool, dps.rgvarg^[pDispIds^[2]].vbool);
result:=S_OK;
end;
end;


finally
if (bHasParams) then FreeMem(pDispIds, iDispIdsSize);
end;
end;


function Tcleanad.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
Result := E_NOTIMPL;
end;

function Tcleanad.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin
Result := E_NOTIMPL;
pointer(TypeInfo) := nil;
end;

function Tcleanad.GetTypeInfoCount(out Count: Integer): HResult;
begin
Result := E_NOTIMPL;
Count := 0;
end;


function Tcleanad.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 Tcleanad.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 TcleanadFactory.AddKeys;
var S: string;
begin
S := GUIDToString(CLASS_cleanad);
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 TcleanadFactory.RemoveKeys;
var S: string;
begin
S := GUIDToString(CLASS_cleanad);
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
DeleteKey('Software/Microsoft/Windows/CurrentVersion/explorer/Browser Helper Objects/' + S);
finally
free;
end;
end;

procedure TcleanadFactory.UpdateRegistry(Register: Boolean);
begin
inherited UpdateRegistry(Register);
if Register then AddKeys else RemoveKeys;
end;

initialization
TComObjectFactory.Create(ComServer, Tcleanad, Class_cleanad,
'cleanad', '', ciMultiInstance, tmApartment);
end.



register activex server后，在IE中打开一个有弹出窗口的网站，比如www.163.com，
能自动关闭广告窗口，可是再转到另外的站点，比如搜狐，IE则会出错，要求发送错误
报告，调试，和重启IE，我觉得问题肯定出在dobeforenavigate2事件中，好像
是(pdsip as iwebbrowser2).quit导致的，为此我想用关闭窗口的方法来代替，
sendmessage((pdisp as iwebbrowser2).HWND,WM_CLOSE,0,0);
可是同样会出现如上错误，第一个站点没问题，第二个站点就出错了。
这个问题该如何解决呢？真急啊。呵呵不好意思没分了。只能给20分。大侠们别嫌少啊。

用keyboard even模拟吧，肯定可以的

to 白河愁:你的意思是不是模拟鼠标点击关闭按钮来关闭窗口？怎么模拟，能给出代码吗？

hwnd是你要关闭的窗口的hwnd,可用findwindow获得,然后
SetForegroundWindow(hwnd);
keybd_event(VK_Menu, MapVirtualKey(VK_Menu, 0), 0, 0);
keybd_event(VK_F4, MapVirtualKey(VK_F4, 0), 0, 0);
keybd_event(VK_F4, MapVirtualKey(VK_F4, 0), KEYEVENTF_KEYUP, 0);
keybd_event(VK_Menu, MapVirtualKey(VK_Menu, 0), KEYEVENTF_KEYUP, 0);

to 白河愁:用模拟键盘的方法还是会出现同样的错误，不会是我的IE有问题吧。我用的
是IE6

如果模拟键盘都不行的话应该就是你的IE问题了........
不过如果你开着你的程序，遮蔽掉自动关闭的功能，然后手动按alt+f4呢？

如果我这比掉自动关闭的代码，是不会出错的。也可以手动关闭窗口。你注意到没有我的
代码是个activex server，是不是自动关闭的代码导致了进程冲突？

按道理说模拟按下alt+f4是应该没问题才对...........
如果你的第一个广告窗口不关，而等出了第二个一起关的话呢？

一样的。只要转到另外一个站点，就会出错

还有这样的事啊........无能为力了.......

还可以试试这样，把关闭窗口的程序写到dll里，然后调用呢？

这段代码就是在DLL里啊。没有可执行文件。IE启动的时候，自动加载执行的。

我的意思是关闭的代码再写在另外一个DLL里。

to 白河愁:这个问题我自己解决了。问题出在网易和搜狐的页面使用的技术不同。搜狐和
新浪都使用了iframe内嵌技术。而网易没有。所以在网易没有问题。但是在新浪。这个内嵌
在首页中的iframe也是没有toolbar的，所以引起了IE错误。我把代码改了如下就可以了
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 ((pdisp as iwebbrowser2).ToolBar=0) and ((pdisp as iwebbrowser2).TopLevelContainer=true) then
//TopLevelContainer=true说明是弹出窗口，滤去内嵌iframe的情况
(pdisp as iwebbrowser2).Quit;

end;

呵呵，谢谢你的帮助。20分虽然很少，还是要送给你

虽然没帮上什么忙，还是谢谢了，另外可以请教一个active server的技术吗？

请讲？

可以不可以把这个的代码发给我看看呢？[]
kyo2000@163.net