pascal/CEF4Delphi
1
0
Fork 0
mirror of https://github.com/salvadordf/CEF4Delphi.git synced 2024-11-24 08:02:15 +02:00
Code Issues Actions Releases Activity

Added TChromiumCore.SetUserAgentOverride procedure

Browse Source 
Added menu option to change the User Agent string at runtime to the MiniBrowser demo.
This commit is contained in:
Salvador Díaz Fau 2020-07-05 12:06:33 +02:00
parent e82dc1a080
commit d394d41991
4 changed files with 38 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
demos/Delphi_VCL/MiniBrowser/uMiniBrowser.dfm
View File

@ -384,6 +384,10 @@ object MiniBrowserFrm: TMiniBrowserFrm
Caption = 'Take screenshot'
OnClick = akescreenshot1Click
end
object Useragent1: TMenuItem
Caption = 'User agent...'
OnClick = Useragent1Click
end
object N5: TMenuItem
Caption = '-'
end

12
demos/Delphi_VCL/MiniBrowser/uMiniBrowser.pas
View File

@ -136,6 +136,7 @@ type
FindText1: TMenuItem;
Clearcache1: TMenuItem;
akescreenshot1: TMenuItem;
Useragent1: TMenuItem;
procedure FormShow(Sender: TObject);
procedure FormCreate(Sender: TObject);
@ -202,6 +203,7 @@ type
procedure FindText1Click(Sender: TObject);
procedure Clearcache1Click(Sender: TObject);
procedure akescreenshot1Click(Sender: TObject);
procedure Useragent1Click(Sender: TObject);
protected
FScreenshotMsgID : integer;
@ -1061,6 +1063,16 @@ begin
Timer1.Enabled := True;
end;
procedure TMiniBrowserFrm.Useragent1Click(Sender: TObject);
var
TempUA : string;
begin
TempUA := inputbox('MiniBrowser demo', 'Set new user agent string', '');
if (length(TempUA) > 0) then
Chromium1.SetUserAgentOverride(TempUA);
end;
procedure TMiniBrowserFrm.BrowserCreatedMsg(var aMessage : TMessage);
begin
CEFWindowParent1.UpdateSize;

21
source/uCEFChromiumCore.pas
View File

@ -695,6 +695,7 @@ type
procedure ResolveHost(const aURL : ustring);
function IsSameBrowser(const aBrowser : ICefBrowser) : boolean;
function ExecuteTaskOnCefThread(aCefThreadId : TCefThreadId; aTaskID : cardinal; aDelayMs : Int64 = 0) : boolean;
procedure SetUserAgentOverride(const aUserAgent : string; const aAcceptLanguage : string = ''; const aPlatform : string = '');
procedure ClearCache;
function DeleteCookies(const url : ustring = ''; const cookieName : ustring = ''; aDeleteImmediately : boolean = False) : boolean;
@ -2962,6 +2963,26 @@ begin
end;
end;
procedure TChromiumCore.SetUserAgentOverride(const aUserAgent, aAcceptLanguage, aPlatform : string);
var
TempParams : ICefDictionaryValue;
begin
try
TempParams := TCefDictionaryValueRef.New;
TempParams.SetString('userAgent', aUserAgent);
if (length(aAcceptLanguage) > 0) then
TempParams.SetString('acceptLanguage', aAcceptLanguage);
if (length(aPlatform) > 0) then
TempParams.SetString('platform', aPlatform);
ExecuteDevToolsMethod(0, 'Emulation.setUserAgentOverride', TempParams);
finally
TempParams := nil;
end;
end;
procedure TChromiumCore.SetYouTubeRestrict(aValue : integer);
begin
if (FYouTubeRestrict <> aValue) then

2
update_CEF4Delphi.json
View File

@ -2,7 +2,7 @@
"UpdateLazPackages" : [
{
"ForceNotify" : true,
"InternalVersion" : 155,
"InternalVersion" : 156,
"Name" : "cef4delphi_lazarus.lpk",
"Version" : "83.4.2.0"
}