这是一个解决方案,适用于使用IE。也许有人能为我提供使用Edge
TEdgeBrowser 弹出菜单的解决方案!
实现需要P D Johnson的以下单元
http://www.delphidabbler.com/articles?article=22。我不知道新的URL地址,抱歉。
{$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;
procedure SetBrowserOleClientSite(const Site: IOleClientSite);
protected
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
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;
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;
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
Result := S_OK;
end;
function TContainerBasis.FilterDataObject(const pDO: IDataObject;
out ppDORet: IDataObject): HResult;
begin
ppDORet := nil;
Result := S_FALSE;
end;
function TContainerBasis.GetContainer(
out container: IOleContainer): HResult;
begin
container := nil;
Result := E_NOINTERFACE;
end;
function TContainerBasis.GetDropTarget(const pDropTarget: IDropTarget;
out ppDropTarget: IDropTarget): HResult;
begin
ppDropTarget := nil;
Result := E_FAIL;
end;
function TContainerBasis.GetExternal(out ppDispatch: IDispatch): HResult;
begin
ppDispatch := nil;
Result := E_FAIL;
end;
function TContainerBasis.GetHostInfo(var pInfo: TDocHostUIInfo): HResult;
begin
Result := S_OK;
end;
function TContainerBasis.GetMoniker(dwAssign, dwWhichMoniker: Integer;
out mk: IMoniker): HResult;
begin
mk := nil;
Result := E_NOTIMPL;
end;
function TContainerBasis.GetOptionKeyPath(var pchKey: POLESTR;
const dw: DWORD): HResult;
begin
Result := E_FAIL;
end;
function TContainerBasis.HideUI: HResult;
begin
Result := S_OK;
end;
function TContainerBasis.OnDocWindowActivate(
const fActivate: BOOL): HResult;
begin
Result := S_OK;
end;
function TContainerBasis.OnFrameWindowActivate(
const fActivate: BOOL): HResult;
begin
Result := S_OK;
end;
function TContainerBasis.OnShowWindow(fShow: BOOL): HResult;
begin
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;
begin
Result := E_NOTIMPL;
end;
function TContainerBasis.ResizeBorder(const prcBorder: PRECT;
const pUIWindow: IOleInPlaceUIWindow; const fFrameWindow: BOOL): HResult;
begin
Result := S_FALSE;
end;
function TContainerBasis.SaveObject: HResult;
begin
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
Result := S_FALSE
end;
function TContainerBasis.ShowObject: HResult;
begin
Result := S_OK;
end;
function TContainerBasis.ShowUI(const dwID: DWORD;
const pActiveObject: IOleInPlaceActiveObject;
const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
const pDoc: IOleInPlaceUIWindow): HResult;
begin
Result := S_OK;
end;
function TContainerBasis.TranslateAccelerator(const lpMsg: PMSG;
const pguidCmdGroup: PGUID; const nCmdID: DWORD): HResult;
begin
Result := S_FALSE;
end;
function TContainerBasis.TranslateUrl(const dwTranslate: DWORD;
const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HResult;
begin
Result := E_FAIL;
end;
function TContainerBasis.UpdateUI: HResult;
begin
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
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;
if Assigned(HostedBrowser.PopupMenu) then
HostedBrowser.PopupMenu.Popup(ApptPos.X, ApptPos.Y);
end
else
Result := S_FALSE;
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;
WebEdge.Navigate('about:blank');
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 =
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 =
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
TPopupMenu
属性的情况。 - SilverWarior