RealICQClient/COM/IEBHO/CIEBHO.pas

unit CIEBHO;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  Windows, ActiveX, Classes, ComObj, Shdocvw, Registry;

type
  TTIEAdvBHO = class(TComObject, IObjectWithSite, IDispatch, IObjectSafety)
  private
    FIESite: IUnknown;
    FIE: IWebBrowser2;
    FCPC: IConnectionPointContainer;
    FCP: IConnectionPoint;
    FCookie: Integer;
    
    FObjectSafetyFlags: DWORD;
  protected
    //IObjectWithSite接口方法定义
    function SetSite(const pUnkSite: IUnknown): HResult; stdcall;
    function GetSite(const riid: TIID; out site: IUnknown): HResult; stdcall;
    //IDispatch接口方法定义
    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;
    //事件处理过程
    procedure DoNewWindow2(var ppDisp: IDispatch; var Cancel: WordBool);
    procedure DoBeforeNavigate2(const pDisp: IDispatch; var URL: OleVariant; var Flags: OleVariant;
                              var TargetFrameName: OleVariant; var PostData: OleVariant;
                              var Headers: OleVariant; var Cancel: WordBool);
                              
    function GetInterfaceSafetyOptions(const IID: TIID; pdwSupportedOptions,
      pdwEnabledOptions: PDWORD): HResult; stdcall;
    function SetInterfaceSafetyOptions(const IID: TIID; dwOptionSetMask,
      dwEnabledOptions: DWORD): HResult; stdcall;
  end;

  
const
  Class_TIEAdvBHO: TGUID = '{49DDFDBB-2D52-4942-AA4A-DE9EB3036DA2}';
  AppKey = '\Software\Winsoft\LxTalk';
  CompanyKeyValue = '\Winsoft'; //做OEM版时，此处应该改为对应公司的网址或名称
  AppTitle = '办公助手';
  
  iAtom: PChar = 'Winsoft';
  
implementation

uses Variants, ComServ, Sysutils, ComConst, ShellAPI, CallClientInterfaceUnit;

{ TTIEAdvBHO }
//------------------------------------------------------------------------------
function TTIEAdvBHO.GetInterfaceSafetyOptions(const IID: TIID;
  pdwSupportedOptions, pdwEnabledOptions: PDWORD): HResult;
var
  Unk: IUnknown;
begin
  if (pdwSupportedOptions = nil) or (pdwEnabledOptions = nil) then
  begin
    Result := E_POINTER;
    Exit;
  end;
  Result := QueryInterface(IID, Unk);
  if Result = S_OK then
  begin
    pdwSupportedOptions^ := INTERFACESAFE_FOR_UNTRUSTED_CALLER or
      INTERFACESAFE_FOR_UNTRUSTED_DATA;
    pdwEnabledOptions^ := FObjectSafetyFlags and
      (INTERFACESAFE_FOR_UNTRUSTED_CALLER or INTERFACESAFE_FOR_UNTRUSTED_DATA);
  end
  else begin
    pdwSupportedOptions^ := 0;
    pdwEnabledOptions^ := 0;
  end;
end;

//------------------------------------------------------------------------------
function TTIEAdvBHO.SetInterfaceSafetyOptions(const IID: TIID;
  dwOptionSetMask, dwEnabledOptions: DWORD): HResult;
var
  Unk: IUnknown;
begin
  Result := QueryInterface(IID, Unk);
  if Result <> S_OK then Exit;
  FObjectSafetyFlags := dwEnabledOptions and dwOptionSetMask;
end;

//------------------------------------------------------------------------------
procedure TTIEAdvBHO.DoBeforeNavigate2(const pDisp: IDispatch; var URL,
  Flags, TargetFrameName, PostData, Headers: OleVariant;
  var Cancel: WordBool);
var
  StrURL,
  BaseURLForOpenTalkingForm,
  LoginName: String;
  Registry: TRegistry;

  FVar: OleVariant;
begin
  BaseURLForOpenTalkingForm := '';

  {从注册表中读取 BaseURL}
  Registry := TRegistry.Create;
  try
    Registry.RootKey := HKEY_LOCAL_MACHINE;

    if Registry.OpenKey(AppKey + CompanyKeyValue, True) then
    begin
      BaseURLForOpenTalkingForm := Registry.ReadString('BaseURLForOpenTalkingForm');
    end;
  finally
    Registry.Free;
  end;
  
  StrURL := URL;
  if (Length(StrURL) > Length(BaseURLForOpenTalkingForm)) and (BaseURLForOpenTalkingForm <> '') then
  begin
    if AnsiSameText(Copy(StrURL, 1, Length(BaseURLForOpenTalkingForm)), BaseURLForOpenTalkingForm) then
    begin
      LoginName := Copy(StrURL, Length(BaseURLForOpenTalkingForm) + 1, Length(StrURL));
      try
        FVar := CreateOleObject('IEBHO.CallClientInterface');
        try
          FVar.OpenTalkingForm(LoginName);
        finally
          FVar := Unassigned;
        end;
      finally
        if not FIE.Visible then
          FIE.Quit
        else
          Cancel := True;
      end;
      
    end;
  end;
end;

//------------------------------------------------------------------------------
procedure TTIEAdvBHO.DoNewWindow2(var ppDisp: IDispatch;
  var Cancel: WordBool);
begin
  //判断页面是否显示完全
//  Debugger.LogMsg('NewWindow2');
//  if FIE.ReadyState<>REFRESH_COMPLETELY then
//  begin
//    //不完全，禁止
//    Cancel:=False;
//    ppDisp:=FIE.Application;
//  end;
end;

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

//------------------------------------------------------------------------------
function TTIEAdvBHO.GetSite(const riid: TIID;
  out site: IInterface): HResult;
begin
  if Supports(FIESite, riid, site) then
    Result := S_OK
  else
    Result := E_NOINTERFACE;
end;

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

//------------------------------------------------------------------------------
function TTIEAdvBHO.GetTypeInfoCount(out Count: Integer): HResult;
begin
  Result := E_NOTIMPL;
  Count := 0;
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 TTIEAdvBHO.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HResult;
var
  dps: TDispParams absolute Params;
  bHasParams: boolean;
  pDispIds: PDispIdList;
  iDispIdsSize: integer;
begin
  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);
    Result := S_OK;
    case DispId of
//      251://NEWWINDOW2事件ID
//        begin
//          DoNewWindow2(IDispatch(dps.rgvarg^[pDispIds^[0]].pdispval^),
//              dps.rgvarg^[pDispIds^[1]].pbool^);
//        end;
      250://BeforeNaviage2事件id
        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^);
        end;
      253://OnQuit事件ID
        begin
          FCP.Unadvise(FCookie);
        end;
    else
      Result := DISP_E_MEMBERNOTFOUND;
    end;
  finally
    if (bHasParams) then
      FreeMem(pDispIds, iDispIdsSize);
  end;
end;

//------------------------------------------------------------------------------
function TTIEAdvBHO.SetSite(const pUnkSite: IInterface): HResult;
begin
  Result := E_FAIL;
  //保存接口
  FIESite := pUnkSite;
  if not Supports(FIESite, IWebBrowser2, FIE) then
    Exit;
  if not Supports(FIE, IConnectionPointContainer, FCPC) then
    Exit;
  //挂接事件
  FCPC.FindConnectionPoint(DWebBrowserEvents2, FCP);
  FCP.Advise(Self, FCookie);
  Result := S_OK;
end;

//------------------------------------------------------------------------------
procedure DeleteRegKeyValue(Root: DWORD; Key: string; ValueName: string = '');
var
  KeyHandle: HKEY;
begin
  if ValueName = '' then
    RegDeleteKey(Root, PChar(Key));
  if RegOpenKey(Root, PChar(Key), KeyHandle) = ERROR_SUCCESS then
  try
    RegDeleteValue(KeyHandle, PChar(ValueName));
  finally
    RegCloseKey(KeyHandle);
  end;
end;

//------------------------------------------------------------------------------
procedure CreateRegKeyValue(Root: DWORD; const Key, ValueName, Value: string);
var
  Handle: HKey;
  Status, Disposition: Integer;
begin
  Status := RegCreateKeyEx(ROOT, PChar(Key), 0, '',
    REG_OPTION_NON_VOLATILE, KEY_READ or KEY_WRITE, nil, Handle,
    @Disposition);
  if Status = 0 then
  begin
    Status := RegSetValueEx(Handle, PChar(ValueName), 0, REG_SZ,
      PChar(Value), Length(Value) + 1);
    RegCloseKey(Handle);
  end;
  if Status <> 0 then
    raise EOleRegistrationError.CreateRes(@SCreateRegKeyError);
end;

type
  TIEAdvBHOFactory = class(TComObjectFactory)
  public
    procedure UpdateRegistry(Register: Boolean); override;
  end;

{ TIEAdvBHOFactory }
//------------------------------------------------------------------------------
procedure TIEAdvBHOFactory.UpdateRegistry(Register: Boolean);
begin
  inherited;
  if Register then
    CreateRegKeyValue(HKEY_LOCAL_MACHINE, 'Software\Microsoft\Windows\CurrentVersion\explorer\Browser Helper Objects\' + GuidToString(ClassID), '', '')
  else
    DeleteRegKeyValue(HKEY_LOCAL_MACHINE, 'Software\Microsoft\Windows\CurrentVersion\explorer\Browser Helper Objects\' + GuidToString(ClassID), '');
end;

initialization
  TIEAdvBHOFactory.Create(ComServer, TTIEAdvBHO, Class_TIEAdvBHO,
    'TIEAdvBHO', '', ciMultiInstance, tmApartment);
end.