Delphi POPUP blocker

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.