CODEWITHSUNDEEP
delphidelphi-xe7twebbrowser
Fabrizio
Fabrizio

Reputation: 8063

How to disable TWebBrowser context menu?

I have a frame which contains a TWebBrowser component and is used by some of my applications and I need to disable the TWebBrowser's default popup menu.

Picture of the default popup menu

I found a solution which works at the application level, by using a TApplicationEvents component and its OnMessage event handler this way:

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;

I'm looking for a solution which works at the frame/TWebBrowser's level, without requiring to add code at the application level.

I've tried assigning the TWebBrowser's TPopupMenu property, but it only works before loading the page on the WebBrowser.

I've tried assigning the TWebBrowser's WindowProc but after a page has been loaded in the WebBrowser, the code is no more executed.

  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;

Upvotes: 3

Views: 1259

Answers (1)

USauter
USauter

Reputation: 335

Here is a solution when using IE. Maybe someone would have a solution for me how to do it with Edge TEdgeBrowser Popup menu!

The following unit from P D Johnson, http://www.delphidabbler.com/articles?article=22 is required for implementation. I do not know the new URL address, sorry.

    {
    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.

And here is the actual program: 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

Upvotes: 1

Related Questions