Delphi TWebBrowser：如何停止重定向到新窗口

Question

我的 TWebBrowser 组件在重定向方面存在问题。下面是显示 Google 图片搜索的代码。当代码运行时，用户会看到一个缩略图，下面是链接：“查找此图像的其他尺寸”。如果单击该链接，则会显示匹配的图像。如果用户随后点击其中一张图片，浏览器将在窗口中间显示一个扩展的黑带，让用户可以访问两个按钮：“访问页面”和“查看图片”：

问题从这里开始。如果我单击“查看图像”按钮，此应用程序将启动一个 Internet Explorer 窗口显示消息：

重定向通知

上一页正在将您发送到...

我该如何阻止这种情况？我不希望在我的 Delphi 应用程序上弹出 IE 窗口，也不希望出现此“重定向通知”。我希望重定向出现在触发重定向的主窗体的 TWebBrowser 中。

Unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.OleCtrls, SHDocVw,
  urlmon;

type
  TForm1 = class(TForm)
    WebBrowser1: TWebBrowser;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  UserAgent : AnsiString;
begin
  UserAgent := 'Mozilla/5.0 (compatible, MSIE 11, Windows NT 6.3; Trident/7.0; rv:11.0) like Gecko';
  UrlMkSetSessionOption(URLMON_OPTION_USERAGENT, PChar(UserAgent), Length(UserAgent)+1, 0);
  WebBrowser1.navigate('http://images.google.com/searchbyimage?site=search&image_url=https://www.google.com/images/branding/googlelogo/2x/googlelogo_color_116x41dp.png');
end;

end.

Answer 1

这是一个如何处理弹出窗口的简短示例。 你需要考虑到你需要处理额外的事件（比如OnWindowSetWidth和OnWindowSetHeight来设置正确的窗口大小。我还删除了你的用户代理代码，因为ActiveX浏览器仍然处于IE7模式。你必须设置FEATURE_BROWSER_EMULATION 标志将浏览器设置为正确的模式。 如果要在同一个浏览器中弹出窗口，仍然需要创建一个弹出窗口并使用OnBeforeNavigate2 事件来捕获重定向Url。请注意，这种工作方式具有破坏性，并且可能会破坏弹出窗口依赖于调用窗口的站点。

Unit Unit1;

interface

uses
  Winapi.Windows,
  Winapi.Messages,
  Generics.Collections,
  System.SysUtils,
  System.Variants,
  System.Classes,
  Vcl.Controls,
  Vcl.Dialogs,
  Vcl.Forms,
  Vcl.OleCtrls,
  SHDocVw,
  MsHtml,
  Registry,
  urlmon, Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    WebBrowser1: TWebBrowser;
    procedure FormCreate(Sender: TObject);
    procedure WebBrowser1NewWindow2(ASender: TObject; var ppDisp: IDispatch; var Cancel: WordBool);
    procedure FormDestroy(Sender: TObject);
    procedure WebBrowser1BeforeNavigate2(ASender: TObject; const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData,
      Headers: OleVariant; var Cancel: WordBool);
  private
    { Private declarations }
    IsPopup : Boolean;
    Popups : TObjectList<TForm1>;
  public
    { Public declarations }
    constructor CreatePopup;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure EmbeddedWebbrowserMode(Mode: Integer);

const
  FEATURE_KEY = 'Software\Microsoft\Internet Explorer\Main\FeatureControl\FEATURE_BROWSER_EMULATION';

var
  AppName: string;
  Reg: TRegistry;

begin
 AppName := ExtractFileName(Application.ExeName);
 Reg := TRegistry.Create();
 try
  Reg.RootKey := HKEY_CURRENT_USER;
  if Reg.OpenKey(FEATURE_KEY, False) then
   begin
    Reg.WriteInteger(AppName, Mode);
    Reg.CloseKey;
   end;
 finally;
  Reg.Free;
 end;
end;

constructor TForm1.CreatePopup;
begin
 IsPopup := True;
 inherited Create(nil);
end;

procedure TForm1.FormCreate(Sender: TObject);

var
  UserAgent : AnsiString;
  Url : string;

begin
 Popups := TObjectList<TForm1>.Create;
 if IsPopup then
  Exit;
 EmbeddedWebbrowserMode(11000);
 Url := 'http://images.google.com/searchbyimage?site=search&image_url=https://www.google.com/images/branding/googlelogo/2x/googlelogo_color_116x41dp.png';
 WebBrowser1.navigate(Url);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 Popups.Free;
end;

procedure TForm1.WebBrowser1BeforeNavigate2(ASender: TObject; const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData,
  Headers: OleVariant; var Cancel: WordBool);
begin
 if IsPopup then
  begin
   Cancel := True;
   Close;
   Form1.WebBrowser1.Navigate(Url);
  end;
end;

procedure TForm1.WebBrowser1NewWindow2(ASender: TObject; var ppDisp: IDispatch; var Cancel: WordBool);

var
  Popup : TForm1;

begin
 Popup := TForm1.CreatePopup;
 Popups.Add(Popup);
 Popup.Visible := False;
 ppDisp := Popup.WebBrowser1.DefaultInterface;
end;

end.

Answer 2

我找到了一个更简单的解决方案，它需要您在主窗体中简单地添加第二个 TWebBrowser 组件：

procedure TMainForm.WebBrowser1NewWindow2(Sender: TObject;
var ppDisp: IDispatch; var Cancel: WordBool);
begin
    ppDisp := WebBrowser2.DefaultDispatch;
end;

procedure TMainForm.WebBrowser2BeforeNavigate2(Sender: TObject;
const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
Headers: OleVariant; var Cancel: WordBool);
begin
    Cancel := True;
    ShowMessage('Here´s the URL: '+URL);
    WebBrowser1.Navigate(URL);
end;