WebBrowser1NewWindow2でURLを取得できますか。 (ID：31990)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

勝爺：「そうですか、では、また次の機会にお待ちしてますから」
真琴：「また予約キャンセルの電話なの？ おじいちゃん」
勝爺：「そうだよ、台風で週末はサーフィンが無理だからって」
真琴：「仕方ないよね、コッチに向かって来るみたいだから、今度の台風は」
勝爺：「オレが若い頃は、この位の台風なら喜んで沖にボードを進めたモンだよ、いい波が来るからな」
真琴：「おじいちゃん、やっぱりそんな危ないコトやってたんだ、昔から…」
勝爺：「"昔"じゃないぞ、マコト、ホンのチョット前のコトだろぅ」
真琴：「そぅかな？^^; でも、もうサーフィンは卒業したんだよね？ おじいちゃん」
勝爺：「卒業？ オレはまだ現役のサーファー、このところチョット休んでるけどな」
真琴：「ずいぶん長い"チョット"だけど^^; その休みズッと長く延ばしてネ、お願い」
勝爺：「まぁ、その気になりゃぁ、また何時だって出来るからな」
春子：「おっはよう〜、はい、今朝の野菜、…台風はコッチ来ちゃうみたいね」
真琴：「そうなの、ねぇ、ハルコさん、また教えて欲しいンだけど」
春子：「いいよ、ナニ？」
真琴：「"NewWindow3"が使えない環境でも、そのURLが簡単に分かる方法はナイの？」
春子：「ん？ "NewWindow2"でも、開こうとしてるURLが分かればイイな〜ってコト？」
真琴：「そう、Win2000では"NewWindow3"が使えないし、IDocHostUIHandlerなんかでは面倒すぎるみたいだし…」
春子：「マコト、出来るよ簡単に、…チョットしたトリックで」

const
  WM_NAVIREDIRECT = WM_APP + 10;
  ......
  private
    procedure RedirectHandler(var Msg: TMessage); message WM_NAVIREDIRECT;
  ......
var
  OpenNewWindow: Boolean;
  TheURL: string;
  TempWB: TWebBrowser;

procedure TForm1.RedirectHandler(var Msg: TMessage);
begin
//WebBrowser1.Navigate(TheURL);
  WebBrowser1.Navigate(PChar(Msg.WParam));
end;

procedure TForm1.WebBrowser1NewWindow2(Sender: TObject;
  var ppDisp: IDispatch; var Cancel: WordBool);
begin
  OpenNewWindow := True;
  if not Assigned(TempWB) then begin
   TempWB := TWebBrowser.Create(Self);
// TempWB.Visible := False;  TempWB.Width := 0;  TempWB.Height := 0;
   TempWB.OnBeforeNavigate2 := WebBrowser1BeforeNavigate2;
  end;
  ppDisp := TempWB.ControlInterface.Application;
end;

procedure TForm1.WebBrowser1BeforeNavigate2(Sender: TObject;
  const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
  Headers: OleVariant; var Cancel: WordBool);
begin
  if OpenNewWindow then begin
   OpenNewWindow := False;
   ShowMessageFmt('新窓をキャンセルして、'#13#10'%s を同じ窓で開くヨ', [URL]);
   Cancel := True;
   TheURL := URL;
   PostMessage(Handle, WM_NAVIREDIRECT, WParam(PChar(TheURL)), 0);
  end else
   .......
end;

真琴：「こんな方法があったの？ ホントにトリックみたい」
春子：「一つ余計にWebBrowserが必要だけどね」
真琴：「ハルコさん、別のIDocHostUIHandlerを実装する方法は、やっぱり大変？」
春子：「まぁ、そうだけど、こんなカンジ…」

const
  DOCHOSTUIDBLCLK_DEFAULT = $0;
  DOCHOSTUIFLAG_THEME     = $40000;

type
  _DOCHOSTUIINFO = packed record
    cbSize: UINT;
    dwFlags: UINT;
    dwDoubleClick: UINT;
    pchHostCss: POLESTR;
    pchHostNS: POLESTR;
  end;

IDocHostUIHandler = interface(IUnknown)
    ['{BD3F23C0-D43E-11CF-893B-00AA00BDCE1A}']
    function ShowContextMenu(dwID: UINT; ppt: PPOINT; const pcmdtReserved: IUnknown;
       const pdispReserved: IDispatch): HResult; stdcall;
    function GetHostInfo(var pInfo: _DOCHOSTUIINFO): HResult; stdcall;
    function ShowUI(dwID: UINT; const pActiveObject: IOleInPlaceActiveObject;
       const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
       const pDoc: IOleInPlaceUIWindow): HResult; stdcall;
    function HideUI: HResult; stdcall;
    function UpdateUI: HResult; stdcall;
    function EnableModeless(fEnable: Integer): HResult; stdcall;
    function OnDocWindowActivate(fActivate: Integer): HResult; stdcall;
    function OnFrameWindowActivate(fActivate: Integer): HResult; stdcall;
    function ResizeBorder(var prcBorder: tagRECT; const pUIWindow: IOleInPlaceUIWindow;
       fRameWindow: Integer): HResult; stdcall;
    function TranslateAccelerator(var lpmsg: tagMSG; var pguidCmdGroup: TGUID; nCmdID: UINT): HResult; stdcall;
    function GetOptionKeyPath(out pchKey: PWideChar; dw: UINT): HResult; stdcall;
    function GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HResult; stdcall;
    function GetExternal(out ppDispatch: IDispatch): HResult; stdcall;
    function TranslateUrl(dwTranslate: UINT; pchURLIn: PWideChar; out ppchURLOut: PWideChar): HResult; stdcall;
    function FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HResult; stdcall;
  end;

TWebBrowser = class(SHDocVw_TLB.TWebBrowser, IDocHostUIHandler)
  protected
    function EnableModeless(fEnable: Integer): HResult; stdcall;
    function FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HResult; stdcall;
    function GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HResult; stdcall;
    function GetExternal(out ppDispatch: IDispatch): HResult; stdcall;
    function GetHostInfo(var pInfo: _DOCHOSTUIINFO): HResult; stdcall;
    function GetOptionKeyPath(out pchKey: PWideChar; dw: UINT): HResult; stdcall;
    function HideUI: HResult; stdcall;
    function OnDocWindowActivate(fActivate: Integer): HResult; stdcall;
    function OnFrameWindowActivate(fActivate: Integer): HResult; stdcall;
    function ResizeBorder(var prcBorder: tagRECT; const pUIWindow: IOleInPlaceUIWindow;
        fRameWindow: Integer): HResult; stdcall;
    function ShowContextMenu(dwID: UINT; ppt: PPOINT; const pcmdtReserved: IUnknown;
        const pdispReserved: IDispatch): HResult; stdcall;
    function ShowUI(dwID: UINT; const pActiveObject: IOleInPlaceActiveObject;
        const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
        const pDoc: IOleInPlaceUIWindow): HResult; stdcall;
    function TranslateAccelerator(var lpmsg: tagMSG; var pguidCmdGroup: TGUID; nCmdID: UINT): HResult; stdcall;
    function TranslateUrl(dwTranslate: UINT; pchURLIn: PWideChar; out ppchURLOut: PWideChar): HResult; stdcall;
    function UpdateUI: HResult; stdcall;
  end;

type
  TForm1 = class(TForm)
    WebBrowser1: TWebBrowser;
    .......

implementation

{$R *.dfm}

var
  TransURL: string;

{TWebBrowser}
function TWebBrowser.TranslateUrl(dwTranslate: UINT; pchURLIn: PWideChar;
  out ppchURLOut: PWideChar): HResult;
begin
  TransURL := pchURLIn;
  ppchURLOut := nil;
  Result := S_FALSE;
end;

function TWebBrowser.GetHostInfo(var pInfo: _DOCHOSTUIINFO): HResult;
begin
  FillChar(pInfo, SizeOf(_DOCHOSTUIINFO), #0);
  pInfo.cbSize := SizeOf(pInfo);
  pInfo.dwFlags := DOCHOSTUIFLAG_THEME;
  pInfo.dwDoubleClick := DOCHOSTUIDBLCLK_DEFAULT;
  Result := S_OK;
end;

function TWebBrowser.EnableModeless;
begin Result := E_NOTIMPL; end;

function TWebBrowser.FilterDataObject;
begin Result := E_NOTIMPL; end;

function TWebBrowser.GetDropTarget(const pDropTarget: IDropTarget;
  out ppDropTarget: IDropTarget): HResult;
begin Result := E_NOTIMPL; end;

function TWebBrowser.GetExternal;
begin Result := S_FALSE; end;

function TWebBrowser.GetOptionKeyPath;
begin Result := E_NOTIMPL; end;

function TWebBrowser.HideUI: HResult;
begin Result := E_NOTIMPL; end;

function TWebBrowser.OnDocWindowActivate;
begin Result := E_NOTIMPL; end;

function TWebBrowser.OnFrameWindowActivate;
begin Result := E_NOTIMPL; end;

function TWebBrowser.ResizeBorder;
begin Result := S_OK; end;

function TWebBrowser.ShowContextMenu;
begin Result := E_NOTIMPL; end;

function TWebBrowser.ShowUI;
begin Result := S_FALSE; end;

function TWebBrowser.TranslateAccelerator;
begin Result := E_NOTIMPL; end;

function TWebBrowser.UpdateUI;
begin Result := S_FALSE; end;

{TForm1}
procedure TForm1.WebBrowser1NewWindow2(Sender: TObject;
  var ppDisp: IDispatch; var Cancel: WordBool);
begin
  ShowMessageFmt('URL = %s'#13#10'※POPUPウィンドウをキャンセルして同じ窓で開くヨ', [TransURL]);
  Cancel := True;
//PostMessage(Handle, WM_NAVIREDIRECT, WParam(PChar(TransURL)), 0);
  WebBrowser1.Navigate(TransURL);
end;

真琴：「ホントに面倒ってカンジだよね^^;」
春子：「でもネ、こっちは別のオマケが付いてるから」
真琴：「どんなオマケ？ 実行して見れば分かるかな？」
春子：「そぅ、…マコト、窓の外も見てごらん、今は上級者のサーファーには絶好の波が来てるよ」
真琴：「ハルコさん…、ちょうど１年後なの、おじいちゃんが海で死んじゃうのは」
春子：「え？ ナンで？ それホントなの？」
真琴：「今みたいに台風が近づいた日の朝早く、おじいちゃんはサーフィンをして…」
春子：「そんな、イヤだよ、マサルさんが居なくなるなんて」
真琴：「アタシだって…だからハルコさんも協力してね、おじいちゃんを助けるのを」
春子：「でも、ナンでマサルさんが今更またサーフィンを始めるの？」
真琴：「年寄りの冷や水、鬼のカクランというか…」
春子：「それはチョットたとえが違うンじゃない？ マコト」

←解決時は質問者本人がここをチェックしてください。

戻る