TWebBrowser:缩放+"一个窗口模式"不兼容

Question

我在尝试什么:

我需要一个总是放大的TWebBrowser(~140%)并将所有链接保存在同一个webbrowser中(即_BLANK链接应该在同一个浏览器控件中打开).

我是怎么做到的:

我已将FEATURE_BROWSER_EMULATION注册表设置为9999,因此使用IE9呈现网页.我已经确认这是有效的.此外,我正在使用IE9全新安装Windows 7运行已编译的程序,通过Windows Update完全更新.

缩放:

procedure TForm1.WebBrowser1DocumentComplete(ASender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  ZoomFac: OLEVariant;
begin
  ZoomFac := 140;
  WebBrowser1.ExecWB(OLECMDID_OPTICAL_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, ZoomFac);
end;

这非常有效.

在同一浏览器控件中打开新窗口:

默认情况下,当TWebBrowser遇到要在新窗口中打开的链接集时,会打开一个新的IE.我需要它留在我的程序/ webbrowser中.

我在这里尝试了很多东西.这对我有用:

procedure TFormWeb.WebBrowser1NewWindow3(ASender: TObject;
  var ppDisp: IDispatch; var Cancel: WordBool; dwFlags: Cardinal;
  const bstrUrlContext, bstrUrl: WideString);
begin
  Cancel := True;
  WebBrowser1.Navigate(bstrUrl);
end;

我取消了新窗口,而只是导航到同一个URL.

互联网上各种页面上的其他来源表明我不会取消,而是将ppDisp设置为各种各样的东西,例如WebBrowser1.DefaultDispath或者WebBrowser1.Application它们的变体.这对我不起作用.当我单击_BLANK链接时,没有任何反应.这是在两台计算机(Win7和IE9)上测试的.我不知道为什么它不起作用,因为这似乎适用于互联网上的其他人.也许这会解决问题？

现在的问题是:

当我结合这两段代码时,它会破坏!

procedure TForm1.Button1Click(Sender: TObject);
begin
  WebBrowser1.Navigate('http://wbm.dk/test.htm');
  // This is a test page, that I created. It just contains a normal link to google.com
end;

procedure TForm1.WebBrowser1DocumentComplete(ASender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  ZoomFac: OLEVariant;
begin
  ZoomFac := 140;
  WebBrowser1.ExecWB(OLECMDID_OPTICAL_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, ZoomFac);
end;

procedure TForm1.WebBrowser1NewWindow3(ASender: TObject; var ppDisp: IDispatch;
  var Cancel: WordBool; dwFlags: Cardinal; const bstrUrlContext,
  bstrUrl: WideString);
begin
  Cancel := True;
  WebBrowser1.Navigate(bstrUrl);
end;

在运行时单击webbrowser中的链接(无论是正常还是_BLANK)时,会产生以下错误:

First chance exception at $75F1B9BC. Exception class EOleException with message 'Unspecified error'. Process Project1.exe (3288)

如果我删除代码的任何一部分,它就可以工作(显然没有删除代码).

任何人都可以帮助我让两件事同时工作吗？

谢谢你的时间!

更新:

现在这是正确捕获新窗口并将其保存在同一浏览器控件中的问题.据我所知,OnDocumentComplete中的缩放代码与它无关.这是一般的放大.如果WebBrowser控件已被缩放(一次就足够了),NewWindow3中的代码将失败并显示"未指定的错误".将缩放级别重置为100%无济于事.

通过使用缩放代码(ExecWB),WebBrowser中的"永久"更改会使其与NewWindow3中的代码不兼容.

任何人都可以搞清楚吗？

新代码:

procedure TForm1.Button1Click(Sender: TObject);
var
  ZoomFac: OLEVariant;
begin
  ZoomFac := 140;
  WebBrowser1.ExecWB(OLECMDID_OPTICAL_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, ZoomFac);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  WebBrowser1.Navigate('http://www.wbm.dk/test.htm');
end;

procedure TForm1.WebBrowser1NewWindow3(ASender: TObject; var ppDisp: IDispatch;
  var Cancel: WordBool; dwFlags: Cardinal; const bstrUrlContext,
  bstrUrl: WideString);
begin
  Cancel := True;
  WebBrowser1.Navigate(bstrUrl);
end;

尝试在单击Button1之前和之后单击链接.缩放后失败.

Answer 1

您可以在事件中设置ppDisp为新实例，例如：IWebBrowser2OnNewWindow2

procedure TForm1.Button1Click(Sender: TObject);
begin
  WebBrowser1.Navigate('http://wbm.dk/test.htm');
end;

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  ZoomFac: OleVariant;
begin
  // the top-level browser
  if pDisp = TWebBrowser(Sender).ControlInterface then
  begin
    ZoomFac := 140;
    TWebBrowser(Sender).ExecWB(OLECMDID_OPTICAL_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, ZoomFac);
  end;
end;

procedure TForm1.WebBrowser1NewWindow2(Sender: TObject;
  var ppDisp: IDispatch; var Cancel: WordBool);
var
  NewWindow: TForm1;
begin
  // ppDisp is nil; this will create a new instance of TForm1:
  NewWindow := TForm1.Create(self);
  NewWindow.Show;
  ppDisp := NewWindow.Webbrowser1.DefaultDispatch;
end;

Microsoft还建议设置RegisterAsBrowser为true.
您可以更改此代码以TWebBrowser在页面控件内的新选项卡中打开。

我们不能设置ppDisp为- 所以使用这个简单的代码的当前实例：TWebBrowser

ppDisp := WebBrowser1.DefaultDispatch;不工作。

如果我们想维护 UI 流程，我们需要“重新创建” current/active - 请注意，在下面的示例中，它是动态创建的，例如：TWebBrowserTWebBrowser

const
  CM_WB_DESTROY = WM_USER + 1;
  OLECMDID_OPTICAL_ZOOM = 63;

type
  TForm1 = class(TForm)
    Button1: TButton;        
    Panel1: TPanel;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    function CreateWebBrowser: TWebBrowser;
    procedure WebBrowserDocumentComplete(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant);
    procedure WebBrowserNewWindow2(Sender: TObject; var ppDisp: IDispatch; var Cancel: WordBool);
    procedure CMWebBrowserDestroy(var Message: TMessage); message CM_WB_DESTROY;
  public
    WebBrowser: TWebBrowser;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  WebBrowser := CreateWebBrowser;
end;

function TForm1.CreateWebBrowser: TWebBrowser;
begin
  Result := TWebBrowser.Create(Self);
  TWinControl(Result).Parent := Panel1;
  Result.Align := alClient;
  Result.OnDocumentComplete := WebBrowserDocumentComplete;
  Result.OnNewWindow2 := WebBrowserNewWindow2;
  Result.RegisterAsBrowser := True;
end;

procedure TForm1.WebBrowserDocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  ZoomFac: OleVariant;
begin
  // the top-level browser
  if pDisp = TWebBrowser(Sender).ControlInterface then
  begin
    ZoomFac := 140;
    TWebBrowser(Sender).ExecWB(OLECMDID_OPTICAL_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, ZoomFac);
  end;
end;

procedure TForm1.WebBrowserNewWindow2(Sender: TObject; var ppDisp: IDispatch; var Cancel: WordBool);
var
  NewWB: TWebBrowser;
begin
  NewWB := CreateWebBrowser;
  ppDisp := NewWB.DefaultDispatch;
  WebBrowser := NewWB;

  // just in case...
  TWebBrowser(Sender).Stop;
  TWebBrowser(Sender).OnDocumentComplete := nil;
  TWebBrowser(Sender).OnNewWindow2 := nil;

  // post a delayed message to destory the current TWebBrowser
  PostMessage(Self.Handle, CM_WB_DESTROY, Integer(TWebBrowser(Sender)), 0);
end;

procedure TForm1.CMWebBrowserDestroy(var Message: TMessage);
var
  Sender: TObject;
begin
  Sender := TObject(Message.WParam);
  if Assigned(Sender) and (Sender is TWebBrowser) then
    TWebBrowser(Sender).Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  WebBrowser.Navigate('http://wbm.dk/test.htm');
end;