TWebBrowserコンポーネントにテーマを適用させる

Delphi

WSGI Containerのブラウザ部分にテーマが適用されてないのはやっぱり気になるので、ちょっとコンポーネントを作ってみた。他の人のようにUIWebBrowserやEmbeddedWBを使うという手もあったんだけど、ライセンス云々が面倒なのでやめておいた。
以下、いい加減なソース。

unit WSGIWB;

interface

uses
  Windows, SysUtils, Classes, Controls, ActiveX, OleCtrls, SHDocVw;

const
  DOCHOSTUIFLAG_THEME = $00040000;
  DOCHOSTUIDBLCLK_DEFAULT = 0;

type
  TDOCHOSTUIINFO = record
    cbSize: ULONG;
    dwFlags: DWORD;
    dwDoubleClick: DWORD;
    chHostCss: POLESTR;
    chHostNS: POLESTR;
  end;

  IDocHostUIHandler = interface(IUnknown)
    ['{bd3f23c0-d43e-11cf-893b-00aa00bdce1a}']
    function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
      const CommandTarget: IUnknown; const Context: IDispatch): HRESULT;
        stdcall;
    function GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT; stdcall;
    function ShowUI(const dwID: DWORD; const pActiveObject:
      IOleInPlaceActiveObject;
      const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
      const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall;
    function HideUI: HRESULT; stdcall;
    function UpdateUI: HRESULT; stdcall;
    function EnableModeless(const fEnable: BOOL): HRESULT; stdcall;
    function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
    function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
    function ResizeBorder(const prcBorder: PRECT;
      const pUIWindow: IOleInPlaceUIWindow;
      const fRameWindow: BOOL): HRESULT; stdcall;
    function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID;
      const nCmdID: DWORD): HRESULT; stdcall;
    function GetOptionKeyPath(out pchKey: POLESTR; const dw: DWORD): HRESULT;
      stdcall;
    function GetDropTarget(const pDropTarget: IDropTarget;
      out ppDropTarget: IDropTarget): HRESULT; stdcall;
    function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall;
    function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR;
      out ppchURLOut: POLESTR): HRESULT; stdcall;
    function FilterDataObject(const pDO: IDataObject;
      out ppDORet: IDataObject): HRESULT; stdcall;
  end;

  TWSGIWB = class(TWebBrowser, IDocHostUIHandler)
  private
    { Private 宣言 }
  protected
    { Protected 宣言 }
  public
    function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
      const CommandTarget: IUnknown; const Context: IDispatch): HRESULT;
        stdcall;
    function GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT; stdcall;
    function ShowUI(const dwID: DWORD; const pActiveObject:
      IOleInPlaceActiveObject;
      const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
      const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall;
    function HideUI: HRESULT; stdcall;
    function UpdateUI: HRESULT; stdcall;
    function EnableModeless(const fEnable: BOOL): HRESULT; stdcall;
    function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
    function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
    function ResizeBorder(const prcBorder: PRECT;
      const pUIWindow: IOleInPlaceUIWindow;
      const fRameWindow: BOOL): HRESULT; stdcall;
    function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID;
      const nCmdID: DWORD): HRESULT; stdcall;
    function GetOptionKeyPath(out pchKey: POLESTR; const dw: DWORD): HRESULT;
      stdcall;
    function GetDropTarget(const pDropTarget: IDropTarget;
      out ppDropTarget: IDropTarget): HRESULT; stdcall;
    function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall;
    function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR;
      out ppchURLOut: POLESTR): HRESULT; stdcall;
    function FilterDataObject(const pDO: IDataObject;
      out ppDORet: IDataObject): HRESULT; stdcall;
  published
    { Published 宣言 }
  end;

procedure Register;

implementation

function TWSGIWB.ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
  const CommandTarget: IUnknown; const Context: IDispatch): HRESULT;
begin
  Result := S_FALSE;
end;

function TWSGIWB.GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT;
begin
  FillChar(pInfo, SizeOf(TDOCHOSTUIINFO), #0);
  pInfo.cbSize := SizeOf(pInfo);
  pInfo.dwFlags := DOCHOSTUIFLAG_THEME;
  pInfo.dwDoubleClick := DOCHOSTUIDBLCLK_DEFAULT;

  Result := S_OK;
end;

function TWSGIWB.ShowUI(const dwID: DWORD; const pActiveObject:
  IOleInPlaceActiveObject;
  const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
  const pDoc: IOleInPlaceUIWindow): HRESULT;
begin
  Result := S_FALSE;
end;

function TWSGIWB.HideUI: HRESULT;
begin
  Result := S_FALSE;
end;

function TWSGIWB.UpdateUI: HRESULT;
begin
  Result := S_FALSE;
end;

function TWSGIWB.EnableModeless(const fEnable: BOOL): HRESULT;
begin
  Result := S_OK;
end;

function TWSGIWB.OnDocWindowActivate(const fActivate: BOOL): HRESULT;
begin
  Result := S_OK;
end;

function TWSGIWB.OnFrameWindowActivate(const fActivate: BOOL): HRESULT;
begin
  Result := S_FALSE;
end;

function TWSGIWB.ResizeBorder(const prcBorder: PRECT;
  const pUIWindow: IOleInPlaceUIWindow;
  const fRameWindow: BOOL): HRESULT;
begin
  Result := S_FALSE;
end;

function TWSGIWB.TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID;
  const nCmdID: DWORD): HRESULT;
begin
  Result := S_FALSE;
end;

function TWSGIWB.GetOptionKeyPath(out pchKey: POLESTR; const dw: DWORD): HRESULT;
begin
  Result := S_OK;
end;

function TWSGIWB.GetDropTarget(const pDropTarget: IDropTarget;
  out ppDropTarget: IDropTarget): HRESULT;
begin
  Result := S_OK;
end;

function TWSGIWB.GetExternal(out ppDispatch: IDispatch): HRESULT;
begin
  Result := S_FALSE;
end;

function TWSGIWB.TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR;
  out ppchURLOut: POLESTR): HRESULT;
begin
  Result := S_FALSE;
end;

function TWSGIWB.FilterDataObject(const pDO: IDataObject;
  out ppDORet: IDataObject): HRESULT;
begin
  Result := S_FALSE;
end;

procedure Register;
begin
  RegisterComponents('WSGI Container', [TWSGIWB]);
end;

end.

IDocHostUIHandlerを実装すればいいらしい。これでうまくいった。