如何禁用 TWebBrowser 上下文菜单？
Posted
技术标签:
【中文标题】如何禁用 TWebBrowser 上下文菜单？【英文标题】：How to disable TWebBrowser context menu? 【发布时间】：2021-09-27 19:13:00 【问题描述】：我有一个包含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;
【问题讨论】：
“它只在网页浏览器上加载页面之前有效” 那么也许你应该在页面加载之后分配它？ @Oliver 加载网页不应该影响使用TPopupMenu 属性的场景。
@Fabrizio 我们在这里谈论的是 WebBrowser 上下文菜单还是 WebPage 上下文菜单。网页可以注册并显示他们自己的自定义上下文菜单，而不是默认的浏览器上下文菜单。
@SilverWarior：我想禁用所有上下文菜单。基本上，我不想让用户右键单击。我通过添加用户右键单击时当前出现的弹出菜单的图片来更新问题
这是彼得·约翰逊的描述表格：How to cusomise teh TWebBrowser user interface (part 4 of 6)
【参考方案1】：
这是使用 IE 时的解决方案。也许有人会为我提供如何使用 Edge TEdgeBrowser Popup menu 的解决方案！
P D 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">' +
'.verlauffont-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
【讨论】：
以上是关于如何禁用 TWebBrowser 上下文菜单？的主要内容，如果未能解决你的问题，请参考以下文章
如何禁用右键单击事件或如何隐藏 Autodesk Forge 查看器上的上下文菜单
WindowChrome - 如何修改或禁用标题栏中的上下文菜单？