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

Question

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

问题开始的地方。如果单击“查看图像”按钮，此应用程序将启动显示消息的Internet Explorer窗口：

重定向通知

上一页正在向您发送...

如何阻止这种情况？我不希望IE窗口弹出我的Delphi应用程序，也不希望出现这个“重定向通知”。我希望重定向出现在触发重定向的主窗体的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来设置正确的窗口大小。我还删除了您的useragent代码，因为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;