Delphi 编写BHO在HTTP头增加自定义属性

把代码贴上(注意：中间省掉了一些类似 DoTitleChange 之类空函数，使用时请自行补齐)：

unit IEHelperUnit;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  Windows, Comobj, ActiveX, SHDOCVW, {MSHTML,} Dialogs, StdVcl, StrUtils;

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 = '{3D898C55-74CC-4B7C-B5F1-45913F368388}';

implementation

uses ComServ, Registry, SysUtils;


procedure DoBeforeNavigate2(const pDisp: IDispatch; var URL: OleVariant; var Flags: OleVariant;
                            var TargetFrameName: OleVariant; var PostData: OleVariant; 
                            var Headers: OleVariant; var Cancel: WordBool);
var
  oldHeader, MyHeader: String;
  newHeader: OleVariant;
begin
  MyHeader := 'register-code: 123456;';
  if AnsiContainsStr(URL, 'sheng.iteye.com') then
  begin
    oldHeader := Headers;
//    Showmessage('正在浏览的HTTP头：' + Headers );
//    Showmessage('你正在浏览的站点：' + BoolToStr(AnsiContainsStr(oldHeader, MyHeader)));
    if not AnsiContainsStr(oldHeader, MyHeader) then
    begin
      newHeader := oldHeader + MyHeader;
//      Showmessage('正在浏览的HTTP头：' + Headers + '修改后的HTTP头：' + newHeader );
      Cancel:=True;
      (pDisp as IWebbrowser2).Stop();
      (pDisp as IWebbrowser2).Navigate2(URL, Flags, TargetFrameName, PostData, newHeader);
    end
  end;
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;
      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.