TWebBrowserとTDBGrid (ID:44755)

名前

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

本文

TWebBrowserの既知の不具合を手軽に修正する方法を研究してましたので、この機会に
今回のT****Gridと絡んだ不具合の修正も加えて完成させてみました。
ただ、、、まだあんまりテストしてません。Windows7や64bitOS環境も未チェックです。
もしよろしければテストしてみてください。

・ActiveControlに関しては、前述のサイトの情報を元に再構築しました。
・textareaとファイル名変更に関しては、古来より伝わるコード？を整頓して使ってます。
※1998年の時点ですでに原型が見られます。
GetClassName function - Experts Exchange（1998/07/28）
http://www.experts-exchange.com/Programming/Languages/Pascal/Delphi/Q_10067496.html

-------------------------------------------------------------------------------
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Grids, OleCtrls, SHDocVw_TLB; // ←環境によりSHDocVwになる

type
  TForm1 = class(TForm)
    WebBrowser1: TWebBrowser;
    WebBrowser2: TWebBrowser;
    StringGrid1: TStringGrid;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  Unit2,   // TWebBrowserFix
  ActiveX; // OleInitialize, OleUninitialize

procedure TForm1.FormCreate(Sender: TObject);
begin
  TWebBrowserFix.Create(WebBrowser1); // Navigateの直前でFixを生成しておく
  WebBrowser1.Navigate('https://www.petitmonte.com/bbs/answers?question_id=8026');

WebBrowser2.Navigate('https://www.petitmonte.com/bbs/answers?question_id=973');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  TWebBrowserFix.Create(WebBrowser2); // 後から任意の時点でFixを生成してもOk
end;

initialization
  OleInitialize(nil);

finalization
  OleUninitialize;

end.

-------------------------------------------------------------------------------
unit Unit2;

interface

uses
  Windows, Messages, Classes, SHDocVw_TLB; // ←環境によりSHDocVwにする

type
  TWebBrowserFix = class(TComponent)
  private
    FIEServerWin: HWND;
    FDefOnNavigateComplete2: TWebBrowserNavigateComplete2;
    function MakeFixProc(): Boolean;
    function GetIEServerWindow(EmbedWin: HWND): HWND;
    procedure FirstTimeNaviComp2(Sender: TObject;
      const pDisp: IDispatch; var URL: OleVariant);
    procedure AppEventsMessage(var Msg: TMsg; var Handled: Boolean);
  public
    constructor Create(AWebBrowser: TWebBrowser); reintroduce;
  end;

implementation

uses
  AppEvnts, // TApplicationEvents
  ActiveX,  // IOleInPlaceActiveObject
  Forms;    // GetParentForm(TControl)

constructor TWebBrowserFix.Create(AWebBrowser: TWebBrowser);
begin
  inherited Create(AWebBrowser);

if MakeFixProc() then Exit;

FDefOnNavigateComplete2:=TWebBrowser(Self.Owner).OnNavigateComplete2;
  TWebBrowser(Self.Owner).OnNavigateComplete2:=FirstTimeNaviComp2;
end;

function TWebBrowserFix.MakeFixProc(): Boolean;
begin
  Result:=False;
  FIEServerWin:=GetIEServerWindow(TWebBrowser(Self.Owner).Handle);
  if FIEServerWin=0 then Exit;

Result:=True;
  TApplicationEvents.Create(Self).OnMessage:=AppEventsMessage;
end;

function TWebBrowserFix.GetIEServerWindow(EmbedWin: HWND): HWND;
var
  DocObjWin: HWND;
begin
  Result:=0;
  if EmbedWin=0 then Exit;

DocObjWin:=FindWindowEx(EmbedWin, 0, 'Shell DocObject View', nil);
  if DocObjWin<>0 then
    Result:=FindWindowEx(DocObjWin, 0, 'Internet Explorer_Server', nil);
end;

procedure TWebBrowserFix.FirstTimeNaviComp2(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
begin
  if Assigned(FDefOnNavigateComplete2) then FDefOnNavigateComplete2(Sender, pDisp, URL);

if not MakeFixProc() then Exit;

TWebBrowser(Self.Owner).OnNavigateComplete2:=FDefOnNavigateComplete2;
end;

procedure TWebBrowserFix.AppEventsMessage(var Msg: TMsg; var Handled: Boolean);
var
  Dispatch: IDispatch;
  iOIPAO:   IOleInPlaceActiveObject;
begin
  if Msg.hwnd<>FIEServerWin then Exit;

// ・TWebBrowserがActiveControlにならないため、TStringGrid等で矢印キー移動できない
  // …という不具合の修正
  case Msg.message of
    WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN: begin
      GetParentForm(TWebBrowser(Self.Owner)).ActiveControl:=TWebBrowser(Self.Owner);
      Exit;
    end;
  end;

// ・Web表示モード時にtextareaで改行が入力できない
  // ・Web表示モード時にtextareaで矢印キー押下でアプリ内の他コントロールに移動してしまう
  // ・フォルダ表示モード（Explorerモード？）時にファイル名を変更できない
  // …という不具合の修正
  Handled:=IsDialogMessage(TWebBrowser(Self.Owner).Handle, Msg);
  if Handled and not (TWebBrowser(Self.Owner).Busy or
     (((Msg.message=WM_KEYDOWN) or (Msg.message=WM_KEYUP)) and
      (Msg.wParam in [VK_BACK, VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN]))) then begin
    Dispatch:=TWebBrowser(Self.Owner).Application;
    if Dispatch<>nil then begin
      Dispatch.QueryInterface(IOleInPlaceActiveObject, iOIPAO);
      if iOIPAO<>nil then iOIPAO.TranslateAccelerator(Msg);
    end;
    Dispatch._Release;
  end;
end;

end.

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

戻る