Delphi POPUP blocker-优快云博客

本文链接：https://blog.youkuaiyun.com/TechnoFantasy/article/details/424335

此博客展示了用Delphi编写的IE弹窗拦截组件代码。定义了TpopBlocker类实现相关接口，处理BeforeNavigate2事件，在SetSite方法中将组件连接到DWebBrowserEvents2事件。还定义了TPOPBlockerFactory类用于更新注册表，实现组件注册与移除。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

unit Unit1;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
Windows, ActiveX, Classes, ComObj, shdocvw, mshtml;

type
TpopBlocker = class(TComObject, IDispatch, IObjectWithSite)
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;
    function SetSite(const pUnkSite: IUnknown): HResult; stdcall;
    function GetSite(const riid: TIID; out site: IUnknown): HResult; stdcall;
private
    m_IE: IWebbrowser2;
    Cookie : integer;
    procedure DoBeforeNavigate2(const pDisp: IDispatch; var URL: OleVariant;
      var Flags: OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant;
      var Headers: OleVariant; var Cancel: WordBool);
end;

TPOPBlockerFactory = class(TComObjectFactory)
private
    procedure AddKeys;
    procedure RemoveKeys;
public
    procedure UpdateRegistry(Register: Boolean); override;
end;
const
Class_popBlocker: TGUID = '{A4F59288-569E-4C41-9C8A-D94E597FF72C}';

implementation

uses ComServ, dialogs, sysutils, Registry;

{ TpopBlocker }
procedure BuildPositionalDispIds(pDispIds: PDispIdList; const dps: TDispParams);
var
i: integer;
begin
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;

procedure TpopBlocker.DoBeforeNavigate2(const pDisp: IDispatch; var URL,
Flags, TargetFrameName, PostData, Headers: OleVariant;
var Cancel: WordBool);
var
i : integer;
begin
if(assigned(m_IE)) then
if(m_IE.ToolBar = 0) then
m_IE.Quit;
end;

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

function TpopBlocker.GetSite(const riid: TIID;
out site: IInterface): HResult;
begin
if Assigned(m_IE) then result:=m_IE.QueryInterface(riid, site)
else
Result:= E_FAIL;
end;

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

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

function TpopBlocker.Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
ArgErr: Pointer): HResult;

var pdpParams: PDispParams;
lpDispIDs: array[0..63] of TDispID;
dwCount: Integer;
begin
//获得参数列表
pdpParams := @Params;

if ((Flags and DISPATCH_METHOD) > 0) then
begin
    ZeroMemory(@lpDispIDs, SizeOf(lpDispIDs));
    // 转换DispID列表
    if (pdpParams^.cArgs > 0) then
    begin
      for dwCount := 0 to Pred(pdpParams^.cArgs) do lpDispIDs[dwCount] := Pred(pdpParams^.cArgs) - dwCount;
      if (pdpParams^.cNamedArgs > 0) then
      begin
        for dwCount := 0 to Pred(pdpParams^.cNamedArgs) do
          lpDispIDs[pdpParams^.rgdispidNamedArgs^[dwCount]] := dwCount;
      end;
    end;
    result := S_OK;

    case DispID of
      //处理BeforeNavigate2事件
      250: DoBeforeNavigate2(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].dispval),
          POleVariant(pdpParams^.rgvarg^[lpDispIds[1]].pvarval)^,
          POleVariant(pdpParams^.rgvarg^[lpDispIds[2]].pvarval)^,
          POleVariant(pdpParams^.rgvarg^[lpDispIds[3]].pvarval)^,
          POleVariant(pdpParams^.rgvarg^[lpDispIds[4]].pvarval)^,
          POleVariant(pdpParams^.rgvarg^[lpDispIds[5]].pvarval)^,
          pdpParams^.rgvarg^[lpDispIds[6]].pbool^);
    end;
end;
end;

function TpopBlocker.SetSite(const pUnkSite: IInterface): HResult;
var
Sp: IServiceProvider;
CPC: IConnectionPointContainer;
CP: ICOnnectionPoint;
begin
//在SetSite方法中将self连接到DWebBrowserEvents2事件上。
if Assigned(pUnkSite) then begin
Sp := pUnkSite as IServiceProvider;

if Assigned(Sp)then //获得pUnkSite的IWebbrowser2接口
Sp.QueryService(IWebbrowserApp, IWebbrowser2, m_IE);

    if Assigned(m_IE) then begin        //将组件连接到m_IE中
      m_IE.QueryInterface(IConnectionPointContainer, CPC);
      if Assigned(CPC) then
      begin
        CPC.FindConnectionPoint(DWebBrowserEvents2 , CP);
        if(assigned(CP)) then
        begin
          CP.Advise(Self, Cookie);
        end;
      end;
    end;
end;
Result := S_OK;
end;

{ TPOPBlockerFactory }

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

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

initialization
TPOPBlockerFactory.Create(ComServer, TpopBlocker, Class_popBlocker,
'popBlocker', '', ciMultiInstance, tmApartment);
end.