delphi - 如何禁用 TWebBrowser 上下文菜单？

Question

我有一个框架，其中包含一个 TWebBrowser 组件并被我的一些应用程序使用，我需要禁用 TWebBrowser 的默认弹出菜单。

我通过使用 TApplicationEvents 组件及其 OnMessage 事件处理程序找到了一个在应用程序级别工作的解决方案:

procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
begin
  if (Msg.Message = WM_RBUTTONDOWN) or (Msg.Message = WM_RBUTTONDBLCLK) then
  begin
    if IsChild(WebBrowser1.Handle, Msg.hwnd) then
    begin
      Handled := True;
    end;
  end;
end;

我正在寻找一种在框架/TWebBrowser 级别工作的解决方案，而无需在应用程序级别添加代码。

我已经尝试分配 TWebBrowser 的 TPopupMenu 属性，但它只在 WebBrowser 上加载页面之前有效。

我已经尝试分配 TWebBrowser 的 WindowProc 但是在 WebBrowser 中加载页面后，代码不再执行。

  private
    FPrevBrowWindowProc : TWndMethod;
    procedure BrowWindowProc(var AMessage: TMessage);

...

procedure TFrame1.BrowWindowProc(var AMessage: TMessage);
begin
  if(AMessage.Msg = WM_RBUTTONDOWN) or (AMessage.Msg = WM_RBUTTONDBLCLK) then 
    Exit;

  if(Assigned(FPrevBrowWindowProc))
  then FPrevBrowWindowProc(AMessage);
end;

constructor TFrame1.Create(AOwner : TComponent);
begin
  inherited;

  FPrevBrowWindowProc := WebBrowser1.WindowProc;
  VS_Brow.WindowProc := BrowWindowProc;
end;

Answer 1

这是使用IE时的解决方法。也许有人会为我提供解决方案，如何使用 Edge TEdgeBrowser Popup menu !

PD Johnson 的以下单位，http://www.delphidabbler.com/articles?article=22是实现所必需的。我不知道新的 URL 地址，抱歉。

    {
    This demo application accompanies the article
    "How to call Delphi code from scripts running in a TWebBrowser" at
    http://www.delphidabbler.com/articles?article=22.

    This unit provides a do-nothing implementation of a web browser OLE container
    object

    This code is copyright (c) P D Johnson (www.delphidabbler.com), 2005-2006.

    v1.0 of 2005/05/09 - original version named UBaseUIHandler.pas
    v2.0 of 2006/02/11 - total rewrite based on unit of same name from article at
                         http://www.delphidabbler.com/articles?article=22
  }


  {$A8,B-,C+,D+,E-,F-,G+,H+,I+,J-,K-,L+,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1}
  {$WARN UNSAFE_TYPE OFF}


  unit UContainerBasis;

  interface

  uses
    Winapi.Windows, Winapi.ActiveX, Winapi.Mshtmhst, SHDocVw;

  type
    TContainerBasis = class(TObject,
      IUnknown, IOleClientSite, IDocHostUIHandler)
    private
      fHostedBrowser: TWebBrowser;
      // Registration method
      procedure SetBrowserOleClientSite(const Site: IOleClientSite);
    protected
      { IUnknown }
      function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
      function _AddRef: Integer; stdcall;
      function _Release: Integer; stdcall;
      { IOleClientSite }
      function SaveObject: HResult; stdcall;
      function GetMoniker(dwAssign: Longint;
        dwWhichMoniker: Longint;
        out mk: IMoniker): HResult; stdcall;
      function GetContainer(
        out container: IOleContainer): HResult; stdcall;
      function ShowObject: HResult; stdcall;
      function OnShowWindow(fShow: BOOL): HResult; stdcall;
      function RequestNewObjectLayout: HResult; stdcall;
      { IDocHostUIHandler }
      function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
        const pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HResult;
        stdcall;
      function GetHostInfo(var pInfo: TDocHostUIInfo): HResult; stdcall;
      function ShowUI(const dwID: DWORD;
        const pActiveObject: IOleInPlaceActiveObject;
        const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
        const pDoc: IOleInPlaceUIWindow): HResult; stdcall;
      function HideUI: HResult; stdcall;
      function UpdateUI: HResult; stdcall;
      function EnableModeless(const fEnable: BOOL): HResult; stdcall;
      function OnDocWindowActivate(const fActivate: BOOL): HResult; stdcall;
      function OnFrameWindowActivate(const fActivate: BOOL): HResult; stdcall;
      function ResizeBorder(const prcBorder: PRECT;
        const pUIWindow: IOleInPlaceUIWindow; const fFrameWindow: BOOL): HResult;
        stdcall;
      function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID;
        const nCmdID: DWORD): HResult; stdcall;
      function GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD ): HResult;
        stdcall;
      function GetDropTarget(const pDropTarget: IDropTarget;
        out ppDropTarget: IDropTarget): HResult; stdcall;
      function GetExternal(out ppDispatch: IDispatch): HResult; stdcall;
      function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR;
        var ppchURLOut: POLESTR): HResult; stdcall;
      function FilterDataObject(const pDO: IDataObject;
        out ppDORet: IDataObject): HResult; stdcall;
    public
      constructor Create(const HostedBrowser: TWebBrowser);
      destructor Destroy; override;
      property HostedBrowser: TWebBrowser read fHostedBrowser;
    end;


  implementation

  uses
    System.SysUtils;

  { TNulWBContainer }

  constructor TContainerBasis.Create(const HostedBrowser: TWebBrowser);
  begin
    Assert(Assigned(HostedBrowser));
    inherited Create;
    fHostedBrowser := HostedBrowser;
    SetBrowserOleClientSite(Self as IOleClientSite);
  end;

  destructor TContainerBasis.Destroy;
  begin
    SetBrowserOleClientSite(nil);
    inherited;
  end;

  function TContainerBasis.EnableModeless(const fEnable: BOOL): HResult;
  begin
    { Return S_OK to indicate we handled (ignored) OK }
    Result := S_OK;
  end;

  function TContainerBasis.FilterDataObject(const pDO: IDataObject;
    out ppDORet: IDataObject): HResult;
  begin
    { Return S_FALSE to show no data object supplied.
      We *must* also set ppDORet to nil }
    ppDORet := nil;
    Result := S_FALSE;
  end;

  function TContainerBasis.GetContainer(
    out container: IOleContainer): HResult;
    {Returns a pointer to the container's IOleContainer
    interface}
  begin
    { We do not support IOleContainer.
      However we *must* set container to nil }
    container := nil;
    Result := E_NOINTERFACE;
  end;

  function TContainerBasis.GetDropTarget(const pDropTarget: IDropTarget;
    out ppDropTarget: IDropTarget): HResult;
  begin
    { Return E_FAIL since no alternative drop target supplied.
      We *must* also set ppDropTarget to nil }
    ppDropTarget := nil;
    Result := E_FAIL;
  end;

  function TContainerBasis.GetExternal(out ppDispatch: IDispatch): HResult;
  begin
    { Return E_FAIL to indicate we failed to supply external object.
      We *must* also set ppDispatch to nil }
    ppDispatch := nil;
    Result := E_FAIL;
  end;

  function TContainerBasis.GetHostInfo(var pInfo: TDocHostUIInfo): HResult;
  begin
    { Return S_OK to indicate UI is OK without changes }
    Result := S_OK;
  end;

  function TContainerBasis.GetMoniker(dwAssign, dwWhichMoniker: Integer;
    out mk: IMoniker): HResult;
    {Returns a moniker to an object's client site}
  begin
    { We don't support monikers.
      However we *must* set mk to nil }
    mk := nil;
    Result := E_NOTIMPL;
  end;

  function TContainerBasis.GetOptionKeyPath(var pchKey: POLESTR;
    const dw: DWORD): HResult;
  begin
    { Return E_FAIL to indicate we failed to override
      default registry settings }
    Result := E_FAIL;
  end;

  function TContainerBasis.HideUI: HResult;
  begin
    { Return S_OK to indicate we handled (ignored) OK }
    Result := S_OK;
  end;

  function TContainerBasis.OnDocWindowActivate(
    const fActivate: BOOL): HResult;
  begin
    { Return S_OK to indicate we handled (ignored) OK }
    Result := S_OK;
  end;

  function TContainerBasis.OnFrameWindowActivate(
    const fActivate: BOOL): HResult;
  begin
    { Return S_OK to indicate we handled (ignored) OK }
    Result := S_OK;
  end;

  function TContainerBasis.OnShowWindow(fShow: BOOL): HResult;
    {Notifies a container when an embedded object's window
    is about to become visible or invisible}
  begin
    { Return S_OK to pretend we've responded to this }
    Result := S_OK;
  end;

  function TContainerBasis.QueryInterface(const IID: TGUID; out Obj): HResult;
  begin
    if GetInterface(IID, Obj) then
      Result := S_OK
    else
      Result := E_NOINTERFACE;
  end;

  function TContainerBasis.RequestNewObjectLayout: HResult;
    {Asks container to allocate more or less space for
    displaying an embedded object}
  begin
    { We don't support requests for a new layout }
    Result := E_NOTIMPL;
  end;

  function TContainerBasis.ResizeBorder(const prcBorder: PRECT;
    const pUIWindow: IOleInPlaceUIWindow; const fFrameWindow: BOOL): HResult;
  begin
    { Return S_FALSE to indicate we did nothing in response }
    Result := S_FALSE;
  end;

  function TContainerBasis.SaveObject: HResult;
    {Saves the object associated with the client site}
  begin
    { Return S_OK to pretend we've done this }
    Result := S_OK;
  end;

  procedure TContainerBasis.SetBrowserOleClientSite(
    const Site: IOleClientSite);
  var
    OleObj: IOleObject;
  begin
    Assert((Site = Self as IOleClientSite) or (Site = nil));
    if not Supports(
      fHostedBrowser.DefaultInterface, IOleObject, OleObj
    ) then
      raise Exception.Create(
        'Browser''s Default interface does not support IOleObject'
      );
    OleObj.SetClientSite(Site);
  end;

  function TContainerBasis.ShowContextMenu(const dwID: DWORD;
    const ppt: PPOINT; const pcmdtReserved: IInterface;
    const pdispReserved: IDispatch): HResult;
  begin
    { Return S_FALSE to notify we didn't display a menu and to
    let browser display its own menu }
    Result := S_FALSE
  end;

  function TContainerBasis.ShowObject: HResult;
    {Tells the container to position the object so it is
    visible to the user}
  begin
    { Return S_OK to pretend we've done this }
    Result := S_OK;
  end;

  function TContainerBasis.ShowUI(const dwID: DWORD;
    const pActiveObject: IOleInPlaceActiveObject;
    const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
    const pDoc: IOleInPlaceUIWindow): HResult;
  begin
    { Return S_OK to say we displayed own UI }
    Result := S_OK;
  end;

  function TContainerBasis.TranslateAccelerator(const lpMsg: PMSG;
    const pguidCmdGroup: PGUID; const nCmdID: DWORD): HResult;
  begin
    { Return S_FALSE to indicate no accelerators are translated }
    Result := S_FALSE;
  end;

  function TContainerBasis.TranslateUrl(const dwTranslate: DWORD;
    const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HResult;
  begin
    { Return E_FAIL to indicate that no translations took place }
    Result := E_FAIL;
  end;

  function TContainerBasis.UpdateUI: HResult;
  begin
    { Return S_OK to indicate we handled (ignored) OK }
    Result := S_OK;
  end;

  function TContainerBasis._AddRef: Integer;
  begin
    Result := -1;
  end;

  function TContainerBasis._Release: Integer;
  begin
    Result := -1;
  end;

  end.

这是实际的程序:UMain.pas

        unit UMain;

    interface

    uses
      Winapi.Windows, Winapi.Messages, Winapi.ActiveX,  Winapi.Mshtmhst,
      System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
      Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.OleCtrls, Vcl.Edge, SHDocVw,
      Vcl.Menus, UContainerBasis, Vcl.StdCtrls;

    const
      HTML= '<!DOCTYPE html><html lang="de"><head><title>Hallo Welt</title><style type="text/css">' +
            '.verlauf{font-size:27px;-webkit-background-clip: text;-webkit-text-fill-color: transparent;' +
            'background-color: #ba254c;background-image: linear-gradient(to right,#ba254c 30%,#392ea4 70%);' +
            'background-size: cover;background-position: center center;}</style>' +
            '</head><body><b class="verlauf">Hallöchen - Welt!</b></body></html>';

    type

      TWBContainer = class(TContainerBasis, IDocHostUIHandler, IOleClientSite)
      private
        FbUserPopUp: boolean;
      protected
        function ShowContextMenu(const AiID: DWORD; const ApptPos: PPOINT;
                                 const AptrCmdtReserved: IUnknown;
                                 const AptrDispReserved: IDispatch): HResult; stdcall;
      public
         property bUserPopUp: Boolean  read  FbUserPopUp
                                       write FbUserPopUp   default False;

      end;

      TForm1 = class(TForm)
        WebIE: TWebBrowser;
        Splitter1: TSplitter;
        WebEdge: TWebBrowser;
        mnp: TPopupMenu;
        Eins1: TMenuItem;
        Zwei1: TMenuItem;
        Drei1: TMenuItem;
        Panel1: TPanel;
        chkIE: TCheckBox;
        chkEdge: TCheckBox;
        procedure FormActivate(Sender: TObject);
        procedure chkIEClick(Sender: TObject);
        procedure FormDestroy(Sender: TObject);
      private
        FEdge  : TEdgeBrowser;
        FWbIe  : TWBContainer;
        FWbEdge: TWBContainer;
      public
        { Public-Deklarationen }
      end;

    var
      Form1: TForm1;

    implementation

    uses
      System.Rtti;


    {$R *.dfm}

    function TWBContainer.ShowContextMenu(const AiID: DWORD; const ApptPos: PPOINT;
                                          const AptrCmdtReserved: IUnknown;
                                          const AptrDispReserved: IDispatch): HResult; stdcall;
    begin
      if bUserPopUp then
      begin
        Result := S_OK; // Ok. I do it myself.
        if Assigned(HostedBrowser.PopupMenu) then
          HostedBrowser.PopupMenu.Popup(ApptPos.X, ApptPos.Y); //Show own Popup
      end
      else
        Result := S_FALSE; // Orign Popup. You do it
    end;

    procedure TForm1.chkIEClick(Sender: TObject);
    begin
      if Sender = chkIE then
        FWbIe.bUserPopUp := chkIE.Checked
      else
        FWbEdge.bUserPopUp := chkEdge.Checked
    end;

    procedure TForm1.FormActivate(Sender: TObject);
    var
      doc: variant;
      LcT: string;
      rtC: TRttiContext;
      rtT: TRttiType;
      rtF: TRttiField;
    begin
      OnActivate := nil;
      FWbIe   := nil;
      FWbEdge := nil;

      Top    := 50;
      Height := 600;
      Width  := 600;

      WebIE.Height := 270;
      WebIE.PopupMenu := mnp;

      FWbIe  := TWBContainer.Create(WebIE);
      FWbIe.bUserPopUp := chkIE.Checked;

      WebIE.Navigate('about:blank');
      doc := WebIE.Document;
      doc.clear;
      doc.write(HTML);
      doc.close;


      LcT := ExtractFilePath(ParamStr(0));
      LcT := LcT + 'WebView2Loader.dll';
      if not FileExists(LcT) then
        raise Exception.Create('WebView2Loader.dll not found!');

      WebEdge.PopupMenu := mnp;
      try
        FWbEdge := TWBContainer.Create(WebEdge);
        FWbEdge.bUserPopUp := chkEdge.Checked;
        chkEdge.Enabled := true;
      except
        on E: Exception do
          ShowMessage(Format('Error %s; %s', [E.Message, E.ClassName]));
      end;


      //to trigger CreateWebView
      WebEdge.Navigate('about:blank');
      //doc := WebEdge.Document;  //0 !!!
      //WebEdge.Navigate(HTML);
      //Exit;

      //Psalm 130, 1
      //  Out of the depths I cry to you, Lord.
      //     https://www.youtube.com/watch?v=lm84E2At9Zk
      rtc := TRttiContext.Create;
      try
        rtt := rtc.GetType(TWebBrowser);
        rtF := rtt.GetField('FEdge');
        FEdge := rtF.GetValue(WebEdge).AsObject as TEdgeBrowser;
      finally
        rtF.Free;
        rtt.Free;
      end;

      while FEdge.BrowserControlState = TCustomEdgeBrowser.TBrowserControlState.Creating do
      begin
        Application.ProcessMessages;
      end;

      FEdge.NavigateToString(HTML);
    end;

    procedure TForm1.FormDestroy(Sender: TObject);
    begin
      FreeAndNil(FWbIe);
      FreeAndNil(FWbEdge);
    end;

    end.

UMain.dfm:

object Form1: TForm1
   Left = 0
   Top = 0
   Caption = 'Form1'
   ClientHeight = 289
   ClientWidth = 554
   Color = clBtnFace
   Font.Charset = DEFAULT_CHARSET
   Font.Color = clWindowText
   Font.Height = -11
   Font.Name = 'Tahoma'
   Font.Style = []
   OldCreateOrder = False
   OnActivate = FormActivate
   OnDestroy = FormDestroy
   PixelsPerInch = 96
   TextHeight = 13
   object Splitter1: TSplitter
     Left = 0
     Top = 185
     Width = 554
     Height = 3
     Cursor = crVSplit
     Align = alTop
     ExplicitTop = 150
     ExplicitWidth = 139
   end
   object Panel1: TPanel
     Left = 0
     Top = 0
     Width = 554
     Height = 35
     Align = alTop
     TabOrder = 2
     object chkIE: TCheckBox
       Left = 19
       Top = 9
       Width = 97
       Height = 17
       Caption = 'IE PopUp'
       Checked = True
       State = cbChecked
       TabOrder = 0
       OnClick = chkIEClick
     end
     object chkEdge: TCheckBox
       Left = 114
       Top = 10
       Width = 97
       Height = 17
       Caption = 'Edge PopUp'
       Enabled = False
       TabOrder = 1
       OnClick = chkIEClick
     end
   end
   object WebIE: TWebBrowser
     Left = 0
     Top = 35
     Width = 554
     Height = 150
     Align = alTop
     PopupMenu = mnp
     TabOrder = 0
     ExplicitLeft = 144
     ExplicitTop = 40
     ExplicitWidth = 300
     ControlData = {
       4C00000042390000810F00000000000000000000000000000000000000000000
       000000004C000000000000000000000001000000E0D057007335CF11AE690800
       2B2E126209000000000000004C0000000114020000000000C000000000000046
       8000000000000000000000000000000000000000000000000000000000000000
       00000000000000000100000000000000000000000000000000000000}
   end
   object WebEdge: TWebBrowser
     Left = 0
     Top = 188
     Width = 554
     Height = 101
     Align = alClient
     PopupMenu = mnp
     TabOrder = 1
     SelectedEngine = EdgeOnly
     ExplicitLeft = 168
     ExplicitTop = 156
     ExplicitWidth = 300
     ExplicitHeight = 150
     ControlData = {
       4C00000042390000700A00000000000000000000000000000000000000000000
       000000004C000000000000000000000001000000E0D057007335CF11AE690800
       2B2E126209000000000000004C0000000114020000000000C000000000000046
       8000000000000000000000000000000000000000000000000000000000000000
       00000000000000000100000000000000000000000000000000000000}
   end
   object mnp: TPopupMenu
     Left = 432
     Top = 40
     object Eins1: TMenuItem
       Caption = 'Eins'
     end
     object Zwei1: TMenuItem
       Caption = 'Zwei'
     end
     object Drei1: TMenuItem
       Caption = 'Drei'
     end
   end
 end