嵌入TWebBrowser使js调用delphi的函数

在JavaScript中，有一个比较特殊的对象，即window.external，用它可以调用浏览器提供的外部方法.
一个很简单的例子就是将当前页添加到收藏夹:
window.external.addFavorite("http://suton.iteye.com","suton的博客");
这样写脚本就可以了。

那么如果我想自己定义external，以便在自己的软件内使用IE核心的浏览器作为UI容器，该如何做呢？本文即是解决此问题。


一、制作TLB
在File | New | Other 菜单下，选择新建一个Type Library，这个向导在ActiveX页内。
然后按下图所示，新建一个接口，在接口下新建一个DoSearchData方法，这个方法即是将来需要添加到external中的。
[img]http://dl.iteye.com/upload/attachment/604421/666a39a8-e421-33c5-a7b1-7ac3080700f1.bmp[/img]
完成添加后，点击保存为TLB按钮，将生成一个TLB文件，此处我将它命名为GetData.tlb


在JavaScript中，有一个比较特殊的对象，即window.external，用它可以调用浏览器提供的外部方法
一个很简单的例子就是将当前页添加到收藏夹
window.external.addFavorite("http://hi.baidu.com/rarnu","橙子的百度博客');
这样写脚本就可以了。

那么如果我想自己定义external，以便在自己的软件内使用IE核心的浏览器作为UI容器，该如何做呢？
本文即是解决此问题。

一、制作TLB
在File | New | Other 菜单下，选择新建一个Type Library，这个向导在ActiveX页内。
然后按下图所示，新建一个接口，在接口下新建一个DoSearchData方法，这个方法即是将来需要添加到external中的。

完成添加后，点击保存为TLB按钮，将生成一个TLB文件，此处我将它命名为GetData.tlb

二、实现IDocHostUIHandler接口
这部分相对比较简单，从MSDN上找到相关的C++代码，把它转换成Delphi的即可。代码如下：

unit DocHostUIHandler;

interface

uses
Windows, ActiveX;
const
 DOCHOSTUIFLAG_DIALOG                      = $00000001;
 DOCHOSTUIFLAG_DISABLE_HELP_MENU           = $00000002;
 DOCHOSTUIFLAG_NO3DBORDER                  = $00000004;
 DOCHOSTUIFLAG_SCROLL_NO                   = $00000008;
 DOCHOSTUIFLAG_DISABLE_SCRIPT_INACTIVE     = $00000010;
 DOCHOSTUIFLAG_OPENNEWWIN                  = $00000020;
 DOCHOSTUIFLAG_DISABLE_OFFSCREEN           = $00000040;
 DOCHOSTUIFLAG_FLAT_SCROLLBAR              = $00000080;
 DOCHOSTUIFLAG_DIV_BLOCKDEFAULT            = $00000100;
 DOCHOSTUIFLAG_ACTIVATE_CLIENTHIT_ONLY     = $00000200;
 DOCHOSTUIFLAG_OVERRIDEBEHAVIORFACTORY     = $00000400;
 DOCHOSTUIFLAG_CODEPAGELINKEDFONTS         = $00000800;
 DOCHOSTUIFLAG_URL_ENCODING_DISABLE_UTF8   = $00001000;
 DOCHOSTUIFLAG_URL_ENCODING_ENABLE_UTF8    = $00002000;
 DOCHOSTUIFLAG_ENABLE_FORMS_AUTOCOMPLETE   = $00004000;
 DOCHOSTUIFLAG_ENABLE_INPLACE_NAVIGATION   = $00010000;
 DOCHOSTUIFLAG_IME_ENABLE_RECONVERSION     = $00020000;
 DOCHOSTUIFLAG_THEME                       = $00040000;
 DOCHOSTUIFLAG_NOTHEME                     = $00080000;
 DOCHOSTUIFLAG_NOPICS                      = $00100000;
 DOCHOSTUIFLAG_NO3DOUTERBORDER             = $00200000;
 DOCHOSTUIFLAG_DISABLE_EDIT_NS_FIXUP       = $1;
 DOCHOSTUIFLAG_LOCAL_MACHINE_ACCESS_CHECK = $1;
 DOCHOSTUIFLAG_DISABLE_UNTRUSTEDPROTOCOL   = $1;
 DOCHOSTUIDBLCLK_DEFAULT         = 0;
 DOCHOSTUIDBLCLK_SHOWPROPERTIES = 1;
 DOCHOSTUIDBLCLK_SHOWCODE        = 2;
 DOCHOSTUITYPE_BROWSE = 0;
 DOCHOSTUITYPE_AUTHOR = 1;

 type
 TDocHostUIInfo = record
     cbSize: ULONG;
     dwFlags: DWORD;
     dwDoubleClick: DWORD;
     pchHostCss: PWChar;
     pchHostNS: PWChar;
 end;

 PDocHostUIInfo = ^TDocHostUIInfo;
 IDocHostUIHandler = interface(IUnknown)
     ['{bd3f23c0-d43e-11cf-893b-00aa00bdce1a}']
     function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
       const pcmdtReserved: IUnknown; const pdispReserved: ispatch): HResult; stdcall;
     function GetHostInfo(var pInfo: TDocHostUIInfo): HResult; dcall;
     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 fFrameWindow: BOOL): HResult;
       stdcall;
     function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID;
       const nCmdID: DWORD): HResult; stdcall;
     function GetOptionKeyPath(var 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;
       var ppchURLOut: POLESTR): HResult; stdcall;
     function FilterDataObject(const pDO: IDataObject;
       out ppDORet: IDataObject): HResult; stdcall;
  end;

implementation

end.

三、实现一个带有IE组件的容器
由于Delphi自带的WebBrowser控件不支持external的直接扩展，因此我们需要另外写一个容器，使它实现IDocHostUIHandler接口，并且通过ActiveX单元的IOleObject.SetClientSite方法，将我们自己的容器填充进去。
这部分的代码直接参考了EmbeddedWB组件的相关实现，具体代码如下：

unit NulContainer;

interface

uses
Windows, ActiveX, SHDocVw, DocHostUIHandler;

type
TNulWBContainer = class(TObject,
    IUnknown, IOleClientSite, IDocHostUIHandler)
private
    fHostedBrowser: TWebBrowser;
    procedure SetBrowserOleClientSite(const Site: IOleClientSite);
protected
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    function SaveObject: HResult; stdcall;
    function GetMoniker(dwAssign: Longint;
      dwWhichMoniker: Longint;
      out mk: IMoniker): HResult; stdcall;
    function GetContainer(
      out container: IOleContainer): HResult; stdcall;
    function ShowObject: HResult; stdcall;
    function OnShowWindow(fShow: BOOL): HResult; stdcall;
    function RequestNewObjectLayout: HResult; stdcall;
    function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
      const pcmdtReserved: IUnknown; const pdispReserved: 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 fFrameWindow: BOOL): HResult;
      stdcall;
    function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID;
      const nCmdID: DWORD): HResult; stdcall;
    function GetOptionKeyPath(var 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;
      var ppchURLOut: POLESTR): HResult; stdcall;
    function FilterDataObject(const pDO: IDataObject;
      out ppDORet: IDataObject): HResult; stdcall;
public
    constructor Create(const HostedBrowser: TWebBrowser);
    destructor Destroy; override;
    property HostedBrowser: TWebBrowser read fHostedBrowser;
end;

implementation

uses
SysUtils;

{ TNulWBContainer }

constructor TNulWBContainer.Create(const HostedBrowser: TWebBrowser);
begin
Assert(Assigned(HostedBrowser));
inherited Create;
fHostedBrowser := HostedBrowser;
SetBrowserOleClientSite(Self as IOleClientSite);
end;

destructor TNulWBContainer.Destroy;
begin
SetBrowserOleClientSite(nil);
inherited;
end;

function TNulWBContainer.EnableModeless(const fEnable: BOOL): HResult;
begin
Result := S_OK;
end;

function TNulWBContainer.FilterDataObject(const pDO: IDataObject;
out ppDORet: IDataObject): HResult;
begin
ppDORet := nil;
Result := S_FALSE;
end;

function TNulWBContainer.GetContainer(
out container: IOleContainer): HResult;
begin
container := nil;
Result := E_NOINTERFACE;
end;

function TNulWBContainer.GetDropTarget(const pDropTarget: IDropTarget;
out ppDropTarget: IDropTarget): HResult;
begin
ppDropTarget := nil;
Result := E_FAIL;
end;

function TNulWBContainer.GetExternal(out ppDispatch: IDispatch): HResult;
begin
ppDispatch := nil;
Result := E_FAIL;
end;

function TNulWBContainer.GetHostInfo(var pInfo: TDocHostUIInfo): HResult;
begin
Result := S_OK;
end;

function TNulWBContainer.GetMoniker(dwAssign, dwWhichMoniker: Integer;
out mk: IMoniker): HResult;
begin
mk := nil;
Result := E_NOTIMPL;
end;

function TNulWBContainer.GetOptionKeyPath(var pchKey: POLESTR;
const dw: DWORD): HResult;
begin
Result := E_FAIL;
end;

function TNulWBContainer.HideUI: HResult;
begin
Result := S_OK;
end;

function TNulWBContainer.OnDocWindowActivate(
const fActivate: BOOL): HResult;
begin
Result := S_OK;
end;

function TNulWBContainer.OnFrameWindowActivate(
const fActivate: BOOL): HResult;
begin
Result := S_OK;
end;

function TNulWBContainer.OnShowWindow(fShow: BOOL): HResult;
begin
Result := S_OK;
end;

function TNulWBContainer.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj) then
    Result := S_OK
else
    Result := E_NOINTERFACE;
end;

function TNulWBContainer.RequestNewObjectLayout: HResult;
begin
Result := E_NOTIMPL;
end;

function TNulWBContainer.ResizeBorder(const prcBorder: PRECT;
const pUIWindow: IOleInPlaceUIWindow; const fFrameWindow: BOOL): HResult;
begin
Result := S_FALSE;
end;

function TNulWBContainer.SaveObject: HResult;
begin
Result := S_OK;
end;

procedure TNulWBContainer.SetBrowserOleClientSite(
const Site: IOleClientSite);
var
OleObj: IOleObject;
begin
Assert((Site = Self as IOleClientSite) or (Site = nil));
if not Supports(fHostedBrowser.DefaultInterface, IOleObject, OleObj) then
    raise Exception.Create('Browser''s Default interface does not support IOleObject');
OleObj.SetClientSite(Site);
end;

function TNulWBContainer.ShowContextMenu(const dwID: DWORD;
const ppt: PPOINT; const pcmdtReserved: IInterface;
const pdispReserved: IDispatch): HResult;
begin
Result := S_FALSE
end;

function TNulWBContainer.ShowObject: HResult;
begin
Result := S_OK;
end;

function TNulWBContainer.ShowUI(const dwID: DWORD;
const pActiveObject: IOleInPlaceActiveObject;
const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
const pDoc: IOleInPlaceUIWindow): HResult;
begin
Result := S_OK;
end;

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

function TNulWBContainer.TranslateUrl(const dwTranslate: DWORD;
const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HResult;
begin
Result := E_FAIL;
end;

function TNulWBContainer.UpdateUI: HResult;
begin
Result := S_OK;
end;

function TNulWBContainer._AddRef: Integer;
begin
Result := -1;
end;

function TNulWBContainer._Release: Integer;
begin
Result := -1;
end;

end.

四、实现TLB内的接口
上面的两个单元都可以当作公共单元来处理，因为以后永远都不再需要修改它们了，下面要做的事情是重点。新建一个VCL Application，然后我们来实现TLB内的接口。

 unit GetData_TLB_Impl;

 interface

 uses
 Classes, ComObj, GetData_TLB;

 type
 TMyExternal = class(TAutoIntfObject, IGetData, IDispatch)
 private
 protected
     function DoSeaarchData(const ASQL: WideString): WideString; safecall;
 public
     constructor Create;
     destructor Destroy; override;
 end;

 implementation

 uses
 SysUtils, ActiveX, StdActns;

 { TMyExternal }

 constructor TMyExternal.Create;
 var
 TypeLib: ITypeLib;
 ExeName: WideString;
 begin
 ExeName := ParamStr(0);
 OleCheck(LoadTypeLib(PWideChar(ExeName), TypeLib));
 inherited Create(TypeLib, IGetData);
 end;

 destructor TMyExternal.Destroy;
 begin
 inherited;
 end;

 function TMyExternal.DoSeaarchData(const ASQL: WideString): WideString; safecall;
 begin
 end;

 end.

这样即是一个实现的了TLB。可以看到，其中有个DoSearchData()方法里是空的，下面我们为它填上代码。

五、编写业务逻辑代码
新建一个Data Module，然后放上ADOConnection与ADOQuery两个控件，相互关联后，连接到SQL Server 2000的一个默认数据库Northwind上。在Data Module内，写一个方法SearchDataHtml()。

 function TDM.SearchDataHtml(ASQL: string): string;
 var
 i: Integer;
 ret: string;
 begin
 ret := '<table border="1" cellspacing="0" cellpadding="0">';
 with Qry do
 begin
     Close;
     SQL.Text := ASQL;
     try
       Open;
     except
       on E: Exception do
       begin
         Result := e.Message;
         Exit;
       end;
     end;
     ret := ret + '<tr>';
     for i:=0 to FieldCount - 1 do
       ret := ret + Format('<td nowrap><b>%s</b></td>',[Fields[i].FieldName]);
     ret := ret + '</tr>';
     First;
     while not Eof do
     begin
       ret := ret + '<tr>';
       for i:=0 to FieldCount - 1 do
       begin
         if Fields[i].DataType in [ftString, ftSmallint, ftInteger, ftWord,
           ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,
           ftAutoInc, ftMemo, ftFmtMemo, ftWideString,
           ftFixedChar, ftLargeint, ftVariant, ftGuid, ftTimeStamp, ftFMTBcd] then
           ret := ret + Format('<td nowrap>%s</td>',[Fields[i].AsString])
         else
           ret := ret + '<td nowrap>(Unsupported Data)</td>';
       end;
       ret := ret + '</tr>';
       Next;
     end;
 end;
 ret := ret+ '</table>';
 Result := ret;
 end;

很明显的，上面的代码即是查询一个表，并把它的内容拼装成一个Table。
然后我们在GetData_TLB_Impl中引用Data Module，并补完DoSearchData()方法中的代码：

 function TMyExternal.DoSeaarchData(const ASQL: WideString): WideString; safecall;
 begin
 Result := DM.SearchDataHtml(ASQL);
 end;

六、实现一个External容器
接下来的事情就很简单了，我们用自己写的external去替换掉浏览器本身的。

 unit ExternalContainer;

 interface

 uses
 ActiveX, SHDocVw,
 DocHostUIHandler, NulContainer, GetData_TLB_Impl;

 type
 TExternalContainer = class(TNulWBContainer, IDocHostUIHandler, IOleClientSite)
 private
     fExternalObj: IDispatch;
 protected
     function GetExternal(out ppDispatch: IDispatch): HResult; stdcall;
 public
     constructor Create(const HostedBrowser: TWebBrowser);
 end;

 implementation

 { TExternalContainer }

 constructor TExternalContainer.Create(const HostedBrowser: TWebBrowser);
 begin
 inherited Create(HostedBrowser);
 fExternalObj := TMyExternal.Create;
 end;

 function TExternalContainer.GetExternal(out ppDispatch: IDispatch): HResult;
 begin
 ppDispatch := fExternalObj;
 Result := S_OK;
 end;

 end.

七、将浏览器控件放进自定义的external容器
就一句代码，就能把把WebBrowser内的external替换了

 procedure TFormMain.FormCreate(Sender: TObject);
 begin
 f := TExternalContainer.Create(WB);
 WB.Navigate(ExtractFilePath(ParamStr(0))+'Data.html');
 end;

八、引用TLB并编译
打开Dpr的源码，添加一句{$R GetData.tlb}，然后编译程序，运行。


九、总结
到此为止，external的替换就结束了