You've already forked CEF4Delphi
mirror of
https://github.com/salvadordf/CEF4Delphi.git
synced 2025-06-12 22:07:39 +02:00
Added WebpageSnapshot demo for UniGUI
This commit is contained in:
Salvador Díaz Fau
18
demos/Delphi_UniGUI/WebpageSnapshot/00-DeleteDCUs.bat
Normal file
18
demos/Delphi_UniGUI/WebpageSnapshot/00-DeleteDCUs.bat
Normal file
@ -0,0 +1,18 @@
|
|||||||
|
del /s /q *.dcu
|
||||||
|
del /s /q *.exe
|
||||||
|
del /s /q *.res
|
||||||
|
del /s /q *.rsm
|
||||||
|
del /s /q *.log
|
||||||
|
del /s /q *.dsk
|
||||||
|
del /s /q *.identcache
|
||||||
|
del /s /q *.stat
|
||||||
|
del /s /q *.local
|
||||||
|
del /s /q *.~*
|
||||||
|
rmdir Win32\Debug
|
||||||
|
rmdir Win32\Release
|
||||||
|
rmdir Win32
|
||||||
|
rmdir Win64\Debug
|
||||||
|
rmdir Win64\Release
|
||||||
|
rmdir Win64
|
||||||
|
rmdir __history
|
||||||
|
rmdir __recovery
|
||||||
166
demos/Delphi_UniGUI/WebpageSnapshot/Main.dfm
Normal file
166
demos/Delphi_UniGUI/WebpageSnapshot/Main.dfm
Normal file
@ -0,0 +1,166 @@
|
|||||||
|
object MainForm: TMainForm
|
||||||
|
Left = 0
|
||||||
|
Top = 0
|
||||||
|
ClientHeight = 645
|
||||||
|
ClientWidth = 800
|
||||||
|
Caption = 'Webpage Snapshot UniGUI'
|
||||||
|
OnShow = UniFormShow
|
||||||
|
BorderStyle = bsSingle
|
||||||
|
OldCreateOrder = False
|
||||||
|
OnClose = UniFormClose
|
||||||
|
BorderIcons = [biSystemMenu]
|
||||||
|
MonitoredKeys.Keys = <>
|
||||||
|
OnCreate = UniFormCreate
|
||||||
|
TextHeight = 15
|
||||||
|
object UniPanel1: TUniPanel
|
||||||
|
Left = 0
|
||||||
|
Top = 0
|
||||||
|
Width = 800
|
||||||
|
Height = 23
|
||||||
|
Hint = ''
|
||||||
|
Align = alTop
|
||||||
|
TabOrder = 0
|
||||||
|
BorderStyle = ubsNone
|
||||||
|
Caption = ''
|
||||||
|
object AddressCb: TUniComboBox
|
||||||
|
Left = 0
|
||||||
|
Top = 0
|
||||||
|
Width = 725
|
||||||
|
Height = 23
|
||||||
|
Hint = ''
|
||||||
|
Text = 'https://www.google.com'
|
||||||
|
Items.Strings = (
|
||||||
|
'https://www.google.com'
|
||||||
|
|
||||||
|
'https://www.whatismybrowser.com/detect/what-http-headers-is-my-b' +
|
||||||
|
'rowser-sending'
|
||||||
|
'https://www.w3schools.com/js/tryit.asp?filename=tryjs_win_close'
|
||||||
|
'https://www.w3schools.com/js/tryit.asp?filename=tryjs_alert'
|
||||||
|
'https://www.w3schools.com/js/tryit.asp?filename=tryjs_loc_assign'
|
||||||
|
|
||||||
|
'https://www.w3schools.com/jsref/tryit.asp?filename=tryjsref_styl' +
|
||||||
|
'e_backgroundcolor'
|
||||||
|
|
||||||
|
'https://www.w3schools.com/Tags/tryit.asp?filename=tryhtml_iframe' +
|
||||||
|
'_name'
|
||||||
|
|
||||||
|
'https://www.w3schools.com/tags/tryit.asp?filename=tryhtml5_input' +
|
||||||
|
'_type_file'
|
||||||
|
|
||||||
|
'https://www.w3schools.com/jsref/tryit.asp?filename=tryjsref_stat' +
|
||||||
|
'e_throw_error'
|
||||||
|
'https://www.htmlquick.com/es/reference/tags/input-file.html'
|
||||||
|
|
||||||
|
'https://developer.mozilla.org/en-US/docs/Web/HTML/Element/input/' +
|
||||||
|
'file'
|
||||||
|
|
||||||
|
'https://developer.mozilla.org/en-US/docs/Web/API/HTMLInputElemen' +
|
||||||
|
't/webkitdirectory'
|
||||||
|
'https://www.w3schools.com/html/html5_video.asp'
|
||||||
|
'http://html5test.com/'
|
||||||
|
|
||||||
|
'https://webrtc.github.io/samples/src/content/devices/input-outpu' +
|
||||||
|
't/'
|
||||||
|
'https://test.webrtc.org/'
|
||||||
|
'https://www.browserleaks.com/webrtc'
|
||||||
|
'https://shaka-player-demo.appspot.com/demo/'
|
||||||
|
'http://webglsamples.org/'
|
||||||
|
'https://get.webgl.org/'
|
||||||
|
'https://www.briskbard.com'
|
||||||
|
'https://www.youtube.com'
|
||||||
|
'https://html5demos.com/drag/'
|
||||||
|
'https://frames-per-second.appspot.com/'
|
||||||
|
|
||||||
|
'https://www.sede.fnmt.gob.es/certificados/persona-fisica/verific' +
|
||||||
|
'ar-estado'
|
||||||
|
'https://www.kirupa.com/html5/accessing_your_webcam_in_html5.htm'
|
||||||
|
'https://www.xdumaine.com/enumerateDevices/test/'
|
||||||
|
|
||||||
|
'https://dagrs.berkeley.edu/sites/default/files/2020-01/sample.pd' +
|
||||||
|
'f'
|
||||||
|
'https://codepen.io/udaymanvar/pen/MWaePBY'
|
||||||
|
|
||||||
|
'https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes/acc' +
|
||||||
|
'ept'
|
||||||
|
'chrome://version/'
|
||||||
|
'chrome://net-internals/'
|
||||||
|
'chrome://tracing/'
|
||||||
|
'chrome://appcache-internals/'
|
||||||
|
'chrome://blob-internals/'
|
||||||
|
'chrome://view-http-cache/'
|
||||||
|
'chrome://credits/'
|
||||||
|
'chrome://histograms/'
|
||||||
|
'chrome://media-internals/'
|
||||||
|
'chrome://kill'
|
||||||
|
'chrome://crash'
|
||||||
|
'chrome://hang'
|
||||||
|
'chrome://shorthang'
|
||||||
|
'chrome://gpuclean'
|
||||||
|
'chrome://gpucrash'
|
||||||
|
'chrome://gpuhang'
|
||||||
|
'chrome://extensions-support'
|
||||||
|
'chrome://process-internals')
|
||||||
|
ItemIndex = 0
|
||||||
|
Align = alClient
|
||||||
|
TabOrder = 1
|
||||||
|
IconItems = <>
|
||||||
|
end
|
||||||
|
object GoBtn: TUniButton
|
||||||
|
Left = 725
|
||||||
|
Top = 0
|
||||||
|
Width = 75
|
||||||
|
Height = 23
|
||||||
|
Hint = ''
|
||||||
|
Caption = 'Go'
|
||||||
|
Align = alRight
|
||||||
|
TabOrder = 2
|
||||||
|
OnClick = GoBtnClick
|
||||||
|
end
|
||||||
|
end
|
||||||
|
object UniStatusBar1: TUniStatusBar
|
||||||
|
Left = 0
|
||||||
|
Top = 623
|
||||||
|
Width = 800
|
||||||
|
Hint = ''
|
||||||
|
Panels = <
|
||||||
|
item
|
||||||
|
Width = 600
|
||||||
|
end>
|
||||||
|
SizeGrip = False
|
||||||
|
Align = alBottom
|
||||||
|
ParentColor = False
|
||||||
|
end
|
||||||
|
object UniMemo1: TUniMemo
|
||||||
|
Left = 0
|
||||||
|
Top = 534
|
||||||
|
Width = 800
|
||||||
|
Height = 89
|
||||||
|
Hint = ''
|
||||||
|
Align = alBottom
|
||||||
|
ReadOnly = True
|
||||||
|
TabOrder = 2
|
||||||
|
end
|
||||||
|
object UniCanvas1: TUniCanvas
|
||||||
|
Left = 0
|
||||||
|
Top = 23
|
||||||
|
Width = 800
|
||||||
|
Height = 511
|
||||||
|
Hint = ''
|
||||||
|
Align = alClient
|
||||||
|
ExplicitLeft = 200
|
||||||
|
ExplicitTop = 104
|
||||||
|
ExplicitWidth = 320
|
||||||
|
ExplicitHeight = 320
|
||||||
|
end
|
||||||
|
object UniTimer1: TUniTimer
|
||||||
|
Interval = 100
|
||||||
|
ClientEvent.Strings = (
|
||||||
|
'function(sender)'
|
||||||
|
'{'
|
||||||
|
' '
|
||||||
|
'}')
|
||||||
|
OnTimer = UniTimer1Timer
|
||||||
|
Left = 496
|
||||||
|
Top = 376
|
||||||
|
end
|
||||||
|
end
|
||||||
138
demos/Delphi_UniGUI/WebpageSnapshot/Main.pas
Normal file
138
demos/Delphi_UniGUI/WebpageSnapshot/Main.pas
Normal file
@ -0,0 +1,138 @@
|
|||||||
|
unit Main;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Windows, Messages, SysUtils, Variants, Classes, Graphics,
|
||||||
|
Controls, Forms, uniGUITypes, uniGUIAbstractClasses,
|
||||||
|
uniGUIClasses, uniGUIRegClasses, uniGUIForm, uniImage, uniButton,
|
||||||
|
uniMultiItem, uniComboBox, uniGUIBaseClasses, uniPanel,
|
||||||
|
uCEFBrowserThread, uniStatusBar, uniMemo, uniTimer, uniCanvas;
|
||||||
|
|
||||||
|
type
|
||||||
|
TMainForm = class(TUniForm)
|
||||||
|
UniPanel1: TUniPanel;
|
||||||
|
AddressCb: TUniComboBox;
|
||||||
|
GoBtn: TUniButton;
|
||||||
|
UniStatusBar1: TUniStatusBar;
|
||||||
|
UniMemo1: TUniMemo;
|
||||||
|
UniCanvas1: TUniCanvas;
|
||||||
|
UniTimer1: TUniTimer;
|
||||||
|
procedure UniFormCreate(Sender: TObject);
|
||||||
|
procedure UniFormClose(Sender: TObject; var Action: TCloseAction);
|
||||||
|
procedure GoBtnClick(Sender: TObject);
|
||||||
|
procedure UniFormShow(Sender: TObject);
|
||||||
|
procedure UniTimer1Timer(Sender: TObject);
|
||||||
|
private
|
||||||
|
FThread : TCEFBrowserThread;
|
||||||
|
FMustRefresh : boolean;
|
||||||
|
|
||||||
|
procedure Thread_OnError(Sender: TObject);
|
||||||
|
procedure Thread_OnSnapshotAvailable(Sender: TObject);
|
||||||
|
procedure Thread_OnHTMLAvailable(Sender: TObject);
|
||||||
|
public
|
||||||
|
{ Public declarations }
|
||||||
|
end;
|
||||||
|
|
||||||
|
function MainForm: TMainForm;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{$R *.dfm}
|
||||||
|
|
||||||
|
uses
|
||||||
|
uniGUIVars, MainModule, uniGUIApplication,
|
||||||
|
uCEFApplication;
|
||||||
|
|
||||||
|
function MainForm: TMainForm;
|
||||||
|
begin
|
||||||
|
Result := TMainForm(UniMainModule.GetFormInstance(TMainForm));
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.GoBtnClick(Sender: TObject);
|
||||||
|
begin
|
||||||
|
UniStatusBar1.Panels[0].Text := 'Loading...';
|
||||||
|
screen.cursor := crAppStart;
|
||||||
|
FMustRefresh := False;
|
||||||
|
|
||||||
|
if (FThread = nil) then
|
||||||
|
begin
|
||||||
|
FThread := TCEFBrowserThread.Create(AddressCb.Text, UniCanvas1.Width, UniCanvas1.Height);
|
||||||
|
FThread.OnError := Thread_OnError;
|
||||||
|
FThread.OnSnapshotAvailable := Thread_OnSnapshotAvailable;
|
||||||
|
FThread.OnHTMLAvailable := Thread_OnHTMLAvailable;
|
||||||
|
FThread.SyncEvents := True;
|
||||||
|
FThread.Start;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
FThread.LoadUrl(AddressCb.Text);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.UniFormClose(Sender: TObject; var Action: TCloseAction);
|
||||||
|
begin
|
||||||
|
if (FThread <> nil) then
|
||||||
|
begin
|
||||||
|
if FThread.TerminateBrowserThread then
|
||||||
|
FThread.WaitFor;
|
||||||
|
|
||||||
|
FreeAndNil(FThread);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.UniFormCreate(Sender: TObject);
|
||||||
|
begin
|
||||||
|
FThread := nil;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.UniFormShow(Sender: TObject);
|
||||||
|
begin
|
||||||
|
if GlobalCEFApp.GlobalContextInitialized then
|
||||||
|
UniMemo1.Lines.Add('GlobalCEFApp Initialized')
|
||||||
|
else
|
||||||
|
UniMemo1.Lines.Add('Error: ' + GlobalCEFApp.LastErrorMessage);
|
||||||
|
|
||||||
|
UniMemo1.Refresh;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.UniTimer1Timer(Sender: TObject);
|
||||||
|
begin
|
||||||
|
if FMustRefresh then
|
||||||
|
begin
|
||||||
|
FMustRefresh := False;
|
||||||
|
Repaint;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.Thread_OnError(Sender: TObject);
|
||||||
|
begin
|
||||||
|
UniStatusBar1.Panels[0].Text := 'Error ' + inttostr(FThread.ErrorCode) + ' : ' + FThread.ErrorText + ' - ' + FThread.FailedUrl;
|
||||||
|
screen.cursor := crDefault;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.Thread_OnSnapshotAvailable(Sender: TObject);
|
||||||
|
var
|
||||||
|
TempBitmap : TBitmap;
|
||||||
|
begin
|
||||||
|
TempBitmap := nil;
|
||||||
|
screen.cursor := crDefault;
|
||||||
|
|
||||||
|
if FThread.CopySnapshot(TempBitmap) then
|
||||||
|
begin
|
||||||
|
UniCanvas1.Bitmap.Assign(TempBitmap);
|
||||||
|
UniStatusBar1.Panels[0].Text := 'Snapshot copied successfully';
|
||||||
|
TempBitmap.Free;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
UniStatusBar1.Panels[0].Text := 'There was an error copying the snapshot';
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TMainForm.Thread_OnHTMLAvailable(Sender: TObject);
|
||||||
|
begin
|
||||||
|
UniMemo1.Lines.Add(FThread.HTMLcopy);
|
||||||
|
FMustRefresh := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
initialization
|
||||||
|
RegisterAppFormClass(TMainForm);
|
||||||
|
|
||||||
|
end.
|
||||||
5
demos/Delphi_UniGUI/WebpageSnapshot/MainModule.dfm
Normal file
5
demos/Delphi_UniGUI/WebpageSnapshot/MainModule.dfm
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
object UniMainModule: TUniMainModule
|
||||||
|
MonitoredKeys.Keys = <>
|
||||||
|
Height = 480
|
||||||
|
Width = 640
|
||||||
|
end
|
||||||
32
demos/Delphi_UniGUI/WebpageSnapshot/MainModule.pas
Normal file
32
demos/Delphi_UniGUI/WebpageSnapshot/MainModule.pas
Normal file
@ -0,0 +1,32 @@
|
|||||||
|
unit MainModule;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
uniGUIMainModule, SysUtils, Classes;
|
||||||
|
|
||||||
|
type
|
||||||
|
TUniMainModule = class(TUniGUIMainModule)
|
||||||
|
private
|
||||||
|
{ Private declarations }
|
||||||
|
public
|
||||||
|
{ Public declarations }
|
||||||
|
end;
|
||||||
|
|
||||||
|
function UniMainModule: TUniMainModule;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{$R *.dfm}
|
||||||
|
|
||||||
|
uses
|
||||||
|
UniGUIVars, ServerModule, uniGUIApplication;
|
||||||
|
|
||||||
|
function UniMainModule: TUniMainModule;
|
||||||
|
begin
|
||||||
|
Result := TUniMainModule(UniApplication.UniMainModule)
|
||||||
|
end;
|
||||||
|
|
||||||
|
initialization
|
||||||
|
RegisterMainModuleClass(TUniMainModule);
|
||||||
|
end.
|
||||||
18
demos/Delphi_UniGUI/WebpageSnapshot/ServerModule.dfm
Normal file
18
demos/Delphi_UniGUI/WebpageSnapshot/ServerModule.dfm
Normal file
@ -0,0 +1,18 @@
|
|||||||
|
object UniServerModule: TUniServerModule
|
||||||
|
TempFolder = 'temp\'
|
||||||
|
Title = 'New Application'
|
||||||
|
SuppressErrors = []
|
||||||
|
Bindings = <>
|
||||||
|
SSL.SSLOptions.RootCertFile = 'root.pem'
|
||||||
|
SSL.SSLOptions.CertFile = 'cert.pem'
|
||||||
|
SSL.SSLOptions.KeyFile = 'key.pem'
|
||||||
|
SSL.SSLOptions.Method = sslvSSLv23
|
||||||
|
SSL.SSLOptions.SSLVersions = [sslvTLSv1_1, sslvTLSv1_2]
|
||||||
|
SSL.SSLOptions.Mode = sslmUnassigned
|
||||||
|
SSL.SSLOptions.VerifyMode = []
|
||||||
|
SSL.SSLOptions.VerifyDepth = 0
|
||||||
|
ConnectionFailureRecovery.ErrorMessage = 'Connection Error'
|
||||||
|
ConnectionFailureRecovery.RetryMessage = 'Retrying...'
|
||||||
|
Height = 480
|
||||||
|
Width = 640
|
||||||
|
end
|
||||||
40
demos/Delphi_UniGUI/WebpageSnapshot/ServerModule.pas
Normal file
40
demos/Delphi_UniGUI/WebpageSnapshot/ServerModule.pas
Normal file
@ -0,0 +1,40 @@
|
|||||||
|
unit ServerModule;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils, uniGUIServer, uniGUIMainModule, uniGUIApplication, uIdCustomHTTPServer,
|
||||||
|
uniGUITypes;
|
||||||
|
|
||||||
|
type
|
||||||
|
TUniServerModule = class(TUniGUIServerModule)
|
||||||
|
private
|
||||||
|
{ Private declarations }
|
||||||
|
protected
|
||||||
|
procedure FirstInit; override;
|
||||||
|
public
|
||||||
|
{ Public declarations }
|
||||||
|
end;
|
||||||
|
|
||||||
|
function UniServerModule: TUniServerModule;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{$R *.dfm}
|
||||||
|
|
||||||
|
uses
|
||||||
|
UniGUIVars;
|
||||||
|
|
||||||
|
function UniServerModule: TUniServerModule;
|
||||||
|
begin
|
||||||
|
Result := TUniServerModule(UniGUIServerInstance);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TUniServerModule.FirstInit;
|
||||||
|
begin
|
||||||
|
InitServerModule(Self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
initialization
|
||||||
|
RegisterServerModuleClass(TUniServerModule);
|
||||||
|
end.
|
||||||
@ -0,0 +1,18 @@
|
|||||||
|
program WebpageSnapshotUniGUI;
|
||||||
|
|
||||||
|
uses
|
||||||
|
Forms,
|
||||||
|
ServerModule in 'ServerModule.pas' {UniServerModule: TUniGUIServerModule},
|
||||||
|
MainModule in 'MainModule.pas' {UniMainModule: TUniGUIMainModule},
|
||||||
|
Main in 'Main.pas' {MainForm: TUniForm},
|
||||||
|
uCEFLoader in 'uCEFLoader.pas',
|
||||||
|
uCEFBrowserThread in 'uCEFBrowserThread.pas';
|
||||||
|
|
||||||
|
{$R *.res}
|
||||||
|
|
||||||
|
begin
|
||||||
|
ReportMemoryLeaksOnShutdown := True;
|
||||||
|
Application.Initialize;
|
||||||
|
TUniServerModule.Create(Application);
|
||||||
|
Application.Run;
|
||||||
|
end.
|
||||||
1162
demos/Delphi_UniGUI/WebpageSnapshot/WebpageSnapshotUniGUI.dproj
Normal file
1162
demos/Delphi_UniGUI/WebpageSnapshot/WebpageSnapshotUniGUI.dproj
Normal file
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,48 @@
|
|||||||
|
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
|
||||||
|
<PropertyGroup>
|
||||||
|
<ProjectGuid>{CA1ADB9C-FCE8-4DC1-B7CF-DD26E7B81B65}</ProjectGuid>
|
||||||
|
</PropertyGroup>
|
||||||
|
<ItemGroup>
|
||||||
|
<Projects Include="WebpageSnapshotUniGUI.dproj">
|
||||||
|
<Dependencies/>
|
||||||
|
</Projects>
|
||||||
|
<Projects Include="WebpageSnapshotUniGUI_sp.dproj">
|
||||||
|
<Dependencies/>
|
||||||
|
</Projects>
|
||||||
|
</ItemGroup>
|
||||||
|
<ProjectExtensions>
|
||||||
|
<Borland.Personality>Default.Personality.12</Borland.Personality>
|
||||||
|
<Borland.ProjectType/>
|
||||||
|
<BorlandProject>
|
||||||
|
<Default.Personality/>
|
||||||
|
</BorlandProject>
|
||||||
|
</ProjectExtensions>
|
||||||
|
<Target Name="WebpageSnapshotUniGUI">
|
||||||
|
<MSBuild Projects="WebpageSnapshotUniGUI.dproj"/>
|
||||||
|
</Target>
|
||||||
|
<Target Name="WebpageSnapshotUniGUI:Clean">
|
||||||
|
<MSBuild Projects="WebpageSnapshotUniGUI.dproj" Targets="Clean"/>
|
||||||
|
</Target>
|
||||||
|
<Target Name="WebpageSnapshotUniGUI:Make">
|
||||||
|
<MSBuild Projects="WebpageSnapshotUniGUI.dproj" Targets="Make"/>
|
||||||
|
</Target>
|
||||||
|
<Target Name="WebpageSnapshotUniGUI_sp">
|
||||||
|
<MSBuild Projects="WebpageSnapshotUniGUI_sp.dproj"/>
|
||||||
|
</Target>
|
||||||
|
<Target Name="WebpageSnapshotUniGUI_sp:Clean">
|
||||||
|
<MSBuild Projects="WebpageSnapshotUniGUI_sp.dproj" Targets="Clean"/>
|
||||||
|
</Target>
|
||||||
|
<Target Name="WebpageSnapshotUniGUI_sp:Make">
|
||||||
|
<MSBuild Projects="WebpageSnapshotUniGUI_sp.dproj" Targets="Make"/>
|
||||||
|
</Target>
|
||||||
|
<Target Name="Build">
|
||||||
|
<CallTarget Targets="WebpageSnapshotUniGUI;WebpageSnapshotUniGUI_sp"/>
|
||||||
|
</Target>
|
||||||
|
<Target Name="Clean">
|
||||||
|
<CallTarget Targets="WebpageSnapshotUniGUI:Clean;WebpageSnapshotUniGUI_sp:Clean"/>
|
||||||
|
</Target>
|
||||||
|
<Target Name="Make">
|
||||||
|
<CallTarget Targets="WebpageSnapshotUniGUI:Make;WebpageSnapshotUniGUI_sp:Make"/>
|
||||||
|
</Target>
|
||||||
|
<Import Project="$(BDS)\Bin\CodeGear.Group.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')"/>
|
||||||
|
</Project>
|
||||||
@ -0,0 +1,21 @@
|
|||||||
|
program WebpageSnapshotUniGUI_sp;
|
||||||
|
|
||||||
|
uses
|
||||||
|
uCEFApplicationCore;
|
||||||
|
|
||||||
|
const
|
||||||
|
IMAGE_FILE_LARGE_ADDRESS_AWARE = $0020;
|
||||||
|
|
||||||
|
// CEF needs to set the LARGEADDRESSAWARE ($20) flag which allows 32-bit processes to use up to 3GB of RAM.
|
||||||
|
{$IFDEF WIN32}{$SetPEFlags IMAGE_FILE_LARGE_ADDRESS_AWARE}{$ENDIF}
|
||||||
|
|
||||||
|
begin
|
||||||
|
GlobalCEFApp := TCefApplicationCore.Create;
|
||||||
|
GlobalCEFApp.WindowlessRenderingEnabled := True;
|
||||||
|
GlobalCEFApp.ShowMessageDlg := False;
|
||||||
|
GlobalCEFApp.BlinkSettings := 'hideScrollbars';
|
||||||
|
|
||||||
|
GlobalCEFApp.StartSubProcess;
|
||||||
|
DestroyGlobalCEFApp;
|
||||||
|
end.
|
||||||
|
|
||||||
1115
demos/Delphi_UniGUI/WebpageSnapshot/WebpageSnapshotUniGUI_sp.dproj
Normal file
1115
demos/Delphi_UniGUI/WebpageSnapshot/WebpageSnapshotUniGUI_sp.dproj
Normal file
File diff suppressed because it is too large
Load Diff
715
demos/Delphi_UniGUI/WebpageSnapshot/uCEFBrowserThread.pas
Normal file
715
demos/Delphi_UniGUI/WebpageSnapshot/uCEFBrowserThread.pas
Normal file
@ -0,0 +1,715 @@
|
|||||||
|
unit uCEFBrowserThread;
|
||||||
|
|
||||||
|
{$I ..\..\..\source\cef.inc}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF DELPHI16_UP}
|
||||||
|
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, System.SyncObjs, System.Math,
|
||||||
|
{$ELSE}
|
||||||
|
Windows, Messages, SysUtils, Classes, Graphics, SyncObjs, Math,
|
||||||
|
{$ENDIF}
|
||||||
|
uCEFChromium, uCEFTypes, uCEFInterfaces, uCEFConstants, uCEFBrowserBitmap, uCEFChromiumCore, uCEFMiscFunctions;
|
||||||
|
|
||||||
|
type
|
||||||
|
TCEFBrowserThread = class(TThread)
|
||||||
|
protected
|
||||||
|
FBrowser : TChromium;
|
||||||
|
FBrowserBitmap : TCEFBrowserBitmap;
|
||||||
|
FBrowserSize : TSize;
|
||||||
|
FScreenScale : single;
|
||||||
|
FPopUpBitmap : TBitmap;
|
||||||
|
FPopUpRect : TRect;
|
||||||
|
FResizeCS : TCriticalSection;
|
||||||
|
FBrowserInfoCS : TCriticalSection;
|
||||||
|
FShowPopUp : boolean;
|
||||||
|
FClosing : boolean;
|
||||||
|
FResizing : boolean;
|
||||||
|
FPendingResize : boolean;
|
||||||
|
FInitialized : boolean;
|
||||||
|
FDefaultURL : ustring;
|
||||||
|
FDelayMs : integer;
|
||||||
|
FOnSnapshotAvailable : TNotifyEvent;
|
||||||
|
FOnHTMLAvailable : TNotifyEvent;
|
||||||
|
FOnError : TNotifyEvent;
|
||||||
|
FErrorCode : integer;
|
||||||
|
FErrorText : ustring;
|
||||||
|
FFailedUrl : ustring;
|
||||||
|
FPendingUrl : ustring;
|
||||||
|
FSyncEvents : boolean;
|
||||||
|
FHTMLcopy : ustring;
|
||||||
|
|
||||||
|
function GetErrorCode : integer;
|
||||||
|
function GetErrorText : ustring;
|
||||||
|
function GetFailedUrl : ustring;
|
||||||
|
function GetHTMLcopy : ustring;
|
||||||
|
function GetInitialized : boolean;
|
||||||
|
|
||||||
|
procedure SetErrorText(const aValue : ustring);
|
||||||
|
procedure SetHTMLcopy(const aValue : ustring);
|
||||||
|
|
||||||
|
procedure Browser_OnAfterCreated(Sender: TObject; const browser: ICefBrowser);
|
||||||
|
procedure Browser_OnPaint(Sender: TObject; const browser: ICefBrowser; kind: TCefPaintElementType; dirtyRectsCount: NativeUInt; const dirtyRects: PCefRectArray; const buffer: Pointer; aWidth, aHeight: Integer);
|
||||||
|
procedure Browser_OnGetViewRect(Sender: TObject; const browser: ICefBrowser; var rect: TCefRect);
|
||||||
|
procedure Browser_OnGetScreenPoint(Sender: TObject; const browser: ICefBrowser; viewX, viewY: Integer; var screenX, screenY: Integer; out Result: Boolean);
|
||||||
|
procedure Browser_OnGetScreenInfo(Sender: TObject; const browser: ICefBrowser; var screenInfo: TCefScreenInfo; out Result: Boolean);
|
||||||
|
procedure Browser_OnPopupShow(Sender: TObject; const browser: ICefBrowser; show: Boolean);
|
||||||
|
procedure Browser_OnPopupSize(Sender: TObject; const browser: ICefBrowser; const rect: PCefRect);
|
||||||
|
procedure Browser_OnBeforePopup(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; popup_id: Integer; const targetUrl, targetFrameName: ustring; targetDisposition: TCefWindowOpenDisposition; userGesture: Boolean; const popupFeatures: TCefPopupFeatures; var windowInfo: TCefWindowInfo; var client: ICefClient; var settings: TCefBrowserSettings; var extra_info: ICefDictionaryValue; var noJavascriptAccess: Boolean; var Result: Boolean);
|
||||||
|
procedure Browser_OnBeforeClose(Sender: TObject; const browser: ICefBrowser);
|
||||||
|
procedure Browser_OnLoadError(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; errorCode: TCefErrorCode; const errorText, failedUrl: ustring);
|
||||||
|
procedure Browser_OnLoadingStateChange(Sender: TObject; const browser: ICefBrowser; isLoading, canGoBack, canGoForward: Boolean);
|
||||||
|
procedure Browser_OnTextResultAvailable(Sender: TObject; const aText : ustring);
|
||||||
|
|
||||||
|
procedure DoOnError;
|
||||||
|
procedure DoOnSnapshotAvailable;
|
||||||
|
procedure DoOnHTMLAvailable;
|
||||||
|
procedure Resize;
|
||||||
|
function CreateBrowser : boolean;
|
||||||
|
procedure CloseBrowser;
|
||||||
|
procedure InitError;
|
||||||
|
procedure WebpagePostProcessing;
|
||||||
|
procedure WebpageError;
|
||||||
|
procedure LoadPendingURL;
|
||||||
|
procedure Execute; override;
|
||||||
|
|
||||||
|
public
|
||||||
|
constructor Create(const aDefaultURL : ustring; aWidth, aHeight : integer; aDelayMs : integer = 500; const aScreenScale : single = 1);
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure AfterConstruction; override;
|
||||||
|
function TerminateBrowserThread : boolean;
|
||||||
|
function CopySnapshot(var aSnapshot : TBitmap) : boolean;
|
||||||
|
function SaveSnapshotToFile(const aPath : ustring) : boolean;
|
||||||
|
procedure LoadUrl(const aURL : ustring);
|
||||||
|
|
||||||
|
property ErrorCode : integer read GetErrorCode;
|
||||||
|
property ErrorText : ustring read GetErrorText write SetErrorText;
|
||||||
|
property FailedUrl : ustring read GetFailedUrl;
|
||||||
|
property Initialized : boolean read GetInitialized;
|
||||||
|
property Closing : boolean read FClosing;
|
||||||
|
property SyncEvents : boolean read FSyncEvents write FSyncEvents;
|
||||||
|
property HTMLcopy : ustring read GetHTMLcopy write SetHTMLcopy;
|
||||||
|
|
||||||
|
property OnSnapshotAvailable : TNotifyEvent read FOnSnapshotAvailable write FOnSnapshotAvailable;
|
||||||
|
property OnHTMLAvailable : TNotifyEvent read FOnHTMLAvailable write FOnHTMLAvailable;
|
||||||
|
property OnError : TNotifyEvent read FOnError write FOnError;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
const
|
||||||
|
CEF_WEBPAGE_LOADED_MSG = WM_APP + 1;
|
||||||
|
CEF_WEBPAGE_ERROR_MSG = WM_APP + 2;
|
||||||
|
CEF_CLOSE_BROWSER_MSG = WM_APP + 3;
|
||||||
|
CEF_LOAD_PENDING_URL_MSG = WM_APP + 4;
|
||||||
|
|
||||||
|
constructor TCEFBrowserThread.Create(const aDefaultURL : ustring; aWidth, aHeight, aDelayMs : integer; const aScreenScale : single);
|
||||||
|
begin
|
||||||
|
inherited Create(True);
|
||||||
|
|
||||||
|
FreeOnTerminate := False;
|
||||||
|
FInitialized := False;
|
||||||
|
FBrowser := nil;
|
||||||
|
FBrowserBitmap := nil;
|
||||||
|
FBrowserSize.cx := aWidth;
|
||||||
|
FBrowserSize.cy := aHeight;
|
||||||
|
FScreenScale := aScreenScale;
|
||||||
|
FDefaultURL := aDefaultURL;
|
||||||
|
FPopUpBitmap := nil;
|
||||||
|
FPopUpRect := rect(0, 0, 0, 0);
|
||||||
|
FShowPopUp := False;
|
||||||
|
FResizing := False;
|
||||||
|
FPendingResize := False;
|
||||||
|
FResizeCS := nil;
|
||||||
|
FBrowserInfoCS := nil;
|
||||||
|
FDelayMs := aDelayMs;
|
||||||
|
FOnSnapshotAvailable := nil;
|
||||||
|
FOnHTMLAvailable := nil;
|
||||||
|
FOnError := nil;
|
||||||
|
FClosing := False;
|
||||||
|
FSyncEvents := False;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TCEFBrowserThread.Destroy;
|
||||||
|
begin
|
||||||
|
if (FBrowser <> nil) then
|
||||||
|
FreeAndNil(FBrowser);
|
||||||
|
|
||||||
|
if (FBrowserBitmap <> nil) then
|
||||||
|
FreeAndNil(FBrowserBitmap);
|
||||||
|
|
||||||
|
if (FPopUpBitmap <> nil) then
|
||||||
|
FreeAndNil(FPopUpBitmap);
|
||||||
|
|
||||||
|
if (FResizeCS <> nil) then
|
||||||
|
FreeAndNil(FResizeCS);
|
||||||
|
|
||||||
|
if (FBrowserInfoCS <> nil) then
|
||||||
|
FreeAndNil(FBrowserInfoCS);
|
||||||
|
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.AfterConstruction;
|
||||||
|
begin
|
||||||
|
inherited AfterConstruction;
|
||||||
|
|
||||||
|
FResizeCS := TCriticalSection.Create;
|
||||||
|
FBrowserInfoCS := TCriticalSection.Create;
|
||||||
|
|
||||||
|
FBrowserBitmap := TCEFBrowserBitmap.Create;
|
||||||
|
FBrowserBitmap.PixelFormat := pf32bit;
|
||||||
|
FBrowserBitmap.HandleType := bmDIB;
|
||||||
|
FBrowserBitmap.DeviceScaleFactor := FScreenScale;
|
||||||
|
FBrowserBitmap.SetSize(FBrowserSize.cx, FBrowserSize.cy);
|
||||||
|
|
||||||
|
FBrowser := TChromium.Create(nil);
|
||||||
|
FBrowser.DefaultURL := FDefaultURL;
|
||||||
|
FBrowser.Options.BackgroundColor := CefColorSetARGB($FF, $FF, $FF, $FF);
|
||||||
|
FBrowser.OnAfterCreated := Browser_OnAfterCreated;
|
||||||
|
FBrowser.OnPaint := Browser_OnPaint;
|
||||||
|
FBrowser.OnGetViewRect := Browser_OnGetViewRect;
|
||||||
|
FBrowser.OnGetScreenPoint := Browser_OnGetScreenPoint;
|
||||||
|
FBrowser.OnGetScreenInfo := Browser_OnGetScreenInfo;
|
||||||
|
FBrowser.OnPopupShow := Browser_OnPopupShow;
|
||||||
|
FBrowser.OnPopupSize := Browser_OnPopupSize;
|
||||||
|
FBrowser.OnBeforePopup := Browser_OnBeforePopup;
|
||||||
|
FBrowser.OnBeforeClose := Browser_OnBeforeClose;
|
||||||
|
FBrowser.OnLoadError := Browser_OnLoadError;
|
||||||
|
FBrowser.OnLoadingStateChange := Browser_OnLoadingStateChange;
|
||||||
|
FBrowser.OnTextResultAvailable := Browser_OnTextResultAvailable;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.GetErrorCode : integer;
|
||||||
|
begin
|
||||||
|
if assigned(FBrowserInfoCS) then
|
||||||
|
try
|
||||||
|
FBrowserInfoCS.Acquire;
|
||||||
|
Result := FErrorCode;
|
||||||
|
finally
|
||||||
|
FBrowserInfoCS.Release;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
Result := 0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.GetErrorText : ustring;
|
||||||
|
begin
|
||||||
|
if assigned(FBrowserInfoCS) then
|
||||||
|
try
|
||||||
|
FBrowserInfoCS.Acquire;
|
||||||
|
Result := FErrorText;
|
||||||
|
finally
|
||||||
|
FBrowserInfoCS.Release;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
Result := '';
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.GetFailedUrl : ustring;
|
||||||
|
begin
|
||||||
|
if assigned(FBrowserInfoCS) then
|
||||||
|
try
|
||||||
|
FBrowserInfoCS.Acquire;
|
||||||
|
Result := FFailedUrl;
|
||||||
|
finally
|
||||||
|
FBrowserInfoCS.Release;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
Result := '';
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.GetHTMLcopy : ustring;
|
||||||
|
begin
|
||||||
|
if assigned(FBrowserInfoCS) then
|
||||||
|
try
|
||||||
|
FBrowserInfoCS.Acquire;
|
||||||
|
Result := FHTMLcopy;
|
||||||
|
finally
|
||||||
|
FBrowserInfoCS.Release;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
Result := '';
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.GetInitialized : boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
|
||||||
|
if assigned(FBrowserInfoCS) and assigned(FBrowser) then
|
||||||
|
try
|
||||||
|
FBrowserInfoCS.Acquire;
|
||||||
|
Result := FInitialized and FBrowser.Initialized;
|
||||||
|
finally
|
||||||
|
FBrowserInfoCS.Release;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.SetErrorText(const aValue : ustring);
|
||||||
|
begin
|
||||||
|
if assigned(FBrowserInfoCS) then
|
||||||
|
try
|
||||||
|
FBrowserInfoCS.Acquire;
|
||||||
|
FErrorText := aValue;
|
||||||
|
finally
|
||||||
|
FBrowserInfoCS.Release;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.SetHTMLcopy(const aValue : ustring);
|
||||||
|
begin
|
||||||
|
if assigned(FBrowserInfoCS) then
|
||||||
|
try
|
||||||
|
FBrowserInfoCS.Acquire;
|
||||||
|
FHTMLcopy := aValue;
|
||||||
|
finally
|
||||||
|
FBrowserInfoCS.Release;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.CopySnapshot(var aSnapshot : TBitmap) : boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
|
||||||
|
if FClosing or Terminated or not(Initialized) then exit;
|
||||||
|
|
||||||
|
if assigned(FBrowserInfoCS) then
|
||||||
|
try
|
||||||
|
try
|
||||||
|
FBrowserInfoCS.Acquire;
|
||||||
|
|
||||||
|
if assigned(FBrowserBitmap) and not(FBrowserBitmap.Empty) then
|
||||||
|
begin
|
||||||
|
if (aSnapshot = nil) then
|
||||||
|
begin
|
||||||
|
aSnapshot := TBitmap.Create;
|
||||||
|
aSnapshot.PixelFormat := pf32bit;
|
||||||
|
aSnapshot.HandleType := bmDIB;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if (aSnapshot.Width <> FBrowserBitmap.Width) then
|
||||||
|
aSnapshot.Width := FBrowserBitmap.Width;
|
||||||
|
|
||||||
|
if (aSnapshot.Height <> FBrowserBitmap.Height) then
|
||||||
|
aSnapshot.Height := FBrowserBitmap.Height;
|
||||||
|
|
||||||
|
aSnapshot.Canvas.Draw(0, 0, FBrowserBitmap);
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
except
|
||||||
|
on e : exception do
|
||||||
|
if CustomExceptionHandler('TCEFBrowserThread.CopySnapshot', e) then raise;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FBrowserInfoCS.Release;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.SaveSnapshotToFile(const aPath : ustring) : boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
|
||||||
|
if FClosing or Terminated or not(Initialized) then exit;
|
||||||
|
|
||||||
|
if assigned(FBrowserInfoCS) and (length(aPath) > 0) then
|
||||||
|
try
|
||||||
|
try
|
||||||
|
FBrowserInfoCS.Acquire;
|
||||||
|
|
||||||
|
if assigned(FBrowserBitmap) and not(FBrowserBitmap.Empty) then
|
||||||
|
begin
|
||||||
|
FBrowserBitmap.SaveToFile(aPath);
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
except
|
||||||
|
on e : exception do
|
||||||
|
if CustomExceptionHandler('TCEFBrowserThread.SaveSnapshotToFile', e) then raise;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FBrowserInfoCS.Release;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.LoadUrl(const aURL : ustring);
|
||||||
|
begin
|
||||||
|
if FClosing or Terminated or not(Initialized) then exit;
|
||||||
|
|
||||||
|
if assigned(FBrowserInfoCS) then
|
||||||
|
try
|
||||||
|
FBrowserInfoCS.Acquire;
|
||||||
|
FPendingUrl := aURL;
|
||||||
|
PostThreadMessage(ThreadID, CEF_LOAD_PENDING_URL_MSG, 0, 0);
|
||||||
|
finally
|
||||||
|
FBrowserInfoCS.Release;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.TerminateBrowserThread : boolean;
|
||||||
|
begin
|
||||||
|
Result := Initialized and
|
||||||
|
PostThreadMessage(ThreadID, CEF_CLOSE_BROWSER_MSG, 0, 0);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnAfterCreated(Sender: TObject; const browser: ICefBrowser);
|
||||||
|
begin
|
||||||
|
if assigned(FBrowserInfoCS) then
|
||||||
|
try
|
||||||
|
FBrowserInfoCS.Acquire;
|
||||||
|
FInitialized := True;
|
||||||
|
finally
|
||||||
|
FBrowserInfoCS.Release;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnPaint(Sender: TObject; const browser: ICefBrowser; kind: TCefPaintElementType; dirtyRectsCount: NativeUInt; const dirtyRects: PCefRectArray; const buffer: Pointer; aWidth, aHeight: Integer);
|
||||||
|
var
|
||||||
|
src, dst: PByte;
|
||||||
|
i, j, TempLineSize, TempSrcOffset, TempDstOffset, SrcStride, DstStride : Integer;
|
||||||
|
n : NativeUInt;
|
||||||
|
TempWidth, TempHeight, TempScanlineSize : integer;
|
||||||
|
TempBufferBits : Pointer;
|
||||||
|
TempForcedResize : boolean;
|
||||||
|
TempSrcRect : TRect;
|
||||||
|
begin
|
||||||
|
if assigned(FResizeCS) and assigned(FBrowserBitmap) then
|
||||||
|
try
|
||||||
|
FResizeCS.Acquire;
|
||||||
|
TempForcedResize := False;
|
||||||
|
|
||||||
|
if FBrowserBitmap.BeginDraw then
|
||||||
|
begin
|
||||||
|
if (kind = PET_POPUP) then
|
||||||
|
begin
|
||||||
|
if (FPopUpBitmap = nil) or
|
||||||
|
(aWidth <> FPopUpBitmap.Width) or
|
||||||
|
(aHeight <> FPopUpBitmap.Height) then
|
||||||
|
begin
|
||||||
|
if (FPopUpBitmap <> nil) then FPopUpBitmap.Free;
|
||||||
|
|
||||||
|
FPopUpBitmap := TBitmap.Create;
|
||||||
|
FPopUpBitmap.PixelFormat := pf32bit;
|
||||||
|
FPopUpBitmap.HandleType := bmDIB;
|
||||||
|
FPopUpBitmap.Width := aWidth;
|
||||||
|
FPopUpBitmap.Height := aHeight;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TempWidth := FPopUpBitmap.Width;
|
||||||
|
TempHeight := FPopUpBitmap.Height;
|
||||||
|
TempScanlineSize := FPopUpBitmap.Width * SizeOf(TRGBQuad);
|
||||||
|
TempBufferBits := FPopUpBitmap.Scanline[pred(FPopUpBitmap.Height)];
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
TempForcedResize := FBrowserBitmap.UpdateDimensions(aWidth, aHeight);
|
||||||
|
TempWidth := FBrowserBitmap.Width;
|
||||||
|
TempHeight := FBrowserBitmap.Height;
|
||||||
|
TempScanlineSize := FBrowserBitmap.ScanlineSize;
|
||||||
|
TempBufferBits := FBrowserBitmap.BufferBits;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if (TempBufferBits <> nil) then
|
||||||
|
begin
|
||||||
|
SrcStride := aWidth * SizeOf(TRGBQuad);
|
||||||
|
DstStride := - TempScanlineSize;
|
||||||
|
|
||||||
|
n := 0;
|
||||||
|
|
||||||
|
while (n < dirtyRectsCount) do
|
||||||
|
begin
|
||||||
|
if (dirtyRects[n].x >= 0) and (dirtyRects[n].y >= 0) then
|
||||||
|
begin
|
||||||
|
TempLineSize := min(dirtyRects[n].width, TempWidth - dirtyRects[n].x) * SizeOf(TRGBQuad);
|
||||||
|
|
||||||
|
if (TempLineSize > 0) then
|
||||||
|
begin
|
||||||
|
TempSrcOffset := ((dirtyRects[n].y * aWidth) + dirtyRects[n].x) * SizeOf(TRGBQuad);
|
||||||
|
TempDstOffset := ((TempScanlineSize * pred(TempHeight)) - (dirtyRects[n].y * TempScanlineSize)) +
|
||||||
|
(dirtyRects[n].x * SizeOf(TRGBQuad));
|
||||||
|
|
||||||
|
src := @PByte(buffer)[TempSrcOffset];
|
||||||
|
dst := @PByte(TempBufferBits)[TempDstOffset];
|
||||||
|
|
||||||
|
i := 0;
|
||||||
|
j := min(dirtyRects[n].height, TempHeight - dirtyRects[n].y);
|
||||||
|
|
||||||
|
while (i < j) do
|
||||||
|
begin
|
||||||
|
Move(src^, dst^, TempLineSize);
|
||||||
|
|
||||||
|
Inc(dst, DstStride);
|
||||||
|
Inc(src, SrcStride);
|
||||||
|
inc(i);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
inc(n);
|
||||||
|
end;
|
||||||
|
|
||||||
|
if FShowPopup and (FPopUpBitmap <> nil) then
|
||||||
|
begin
|
||||||
|
TempSrcRect := Rect(0, 0,
|
||||||
|
min(FPopUpRect.Right - FPopUpRect.Left, FPopUpBitmap.Width),
|
||||||
|
min(FPopUpRect.Bottom - FPopUpRect.Top, FPopUpBitmap.Height));
|
||||||
|
|
||||||
|
FBrowserBitmap.BufferDraw(FPopUpBitmap, TempSrcRect, FPopUpRect);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
FBrowserBitmap.EndDraw;
|
||||||
|
|
||||||
|
if (kind = PET_VIEW) then
|
||||||
|
begin
|
||||||
|
if TempForcedResize or FPendingResize then
|
||||||
|
PostThreadMessage(ThreadID, CEF_PENDINGRESIZE, 0, 0);
|
||||||
|
|
||||||
|
FResizing := False;
|
||||||
|
FPendingResize := False;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FResizeCS.Release;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnGetViewRect(Sender: TObject; const browser: ICefBrowser; var rect: TCefRect);
|
||||||
|
begin
|
||||||
|
rect.x := 0;
|
||||||
|
rect.y := 0;
|
||||||
|
rect.width := DeviceToLogical(FBrowserBitmap.Width, FScreenScale);
|
||||||
|
rect.height := DeviceToLogical(FBrowserBitmap.Height, FScreenScale);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnGetScreenPoint(Sender: TObject; const browser: ICefBrowser; viewX, viewY: Integer; var screenX, screenY: Integer; out Result: Boolean);
|
||||||
|
begin
|
||||||
|
screenX := LogicalToDevice(viewX, FScreenScale);
|
||||||
|
screenY := LogicalToDevice(viewY, FScreenScale);
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnGetScreenInfo(Sender: TObject; const browser: ICefBrowser; var screenInfo: TCefScreenInfo; out Result: Boolean);
|
||||||
|
var
|
||||||
|
TempRect : TCEFRect;
|
||||||
|
begin
|
||||||
|
TempRect.x := 0;
|
||||||
|
TempRect.y := 0;
|
||||||
|
TempRect.width := DeviceToLogical(FBrowserBitmap.Width, FScreenScale);
|
||||||
|
TempRect.height := DeviceToLogical(FBrowserBitmap.Height, FScreenScale);
|
||||||
|
|
||||||
|
screenInfo.device_scale_factor := FScreenScale;
|
||||||
|
screenInfo.depth := 0;
|
||||||
|
screenInfo.depth_per_component := 0;
|
||||||
|
screenInfo.is_monochrome := Ord(False);
|
||||||
|
screenInfo.rect := TempRect;
|
||||||
|
screenInfo.available_rect := TempRect;
|
||||||
|
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnPopupShow(Sender: TObject; const browser: ICefBrowser; show: Boolean);
|
||||||
|
begin
|
||||||
|
if show then
|
||||||
|
FShowPopUp := True
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
FShowPopUp := False;
|
||||||
|
FPopUpRect := rect(0, 0, 0, 0);
|
||||||
|
|
||||||
|
if (FBrowser <> nil) then FBrowser.Invalidate(PET_VIEW);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnPopupSize(Sender: TObject; const browser: ICefBrowser; const rect: PCefRect);
|
||||||
|
begin
|
||||||
|
LogicalToDevice(rect^, FScreenScale);
|
||||||
|
|
||||||
|
FPopUpRect.Left := rect.x;
|
||||||
|
FPopUpRect.Top := rect.y;
|
||||||
|
FPopUpRect.Right := rect.x + rect.width - 1;
|
||||||
|
FPopUpRect.Bottom := rect.y + rect.height - 1;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnBeforePopup(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; popup_id: Integer; const targetUrl, targetFrameName: ustring; targetDisposition: TCefWindowOpenDisposition; userGesture: Boolean; const popupFeatures: TCefPopupFeatures; var windowInfo: TCefWindowInfo; var client: ICefClient; var settings: TCefBrowserSettings; var extra_info: ICefDictionaryValue; var noJavascriptAccess: Boolean; var Result: Boolean);
|
||||||
|
begin
|
||||||
|
// For simplicity, this demo blocks all popup windows and new tabs
|
||||||
|
Result := (targetDisposition in [CEF_WOD_NEW_FOREGROUND_TAB, CEF_WOD_NEW_BACKGROUND_TAB, CEF_WOD_NEW_POPUP, CEF_WOD_NEW_WINDOW]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnBeforeClose(Sender: TObject; const browser: ICefBrowser);
|
||||||
|
begin
|
||||||
|
PostThreadMessage(ThreadID, WM_QUIT, 0, 0);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnLoadError(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; errorCode: TCefErrorCode; const errorText, failedUrl: ustring);
|
||||||
|
begin
|
||||||
|
if not(FClosing) and not(Terminated) and (frame <> nil) and frame.IsValid and frame.IsMain and assigned(FBrowserInfoCS) then
|
||||||
|
try
|
||||||
|
FBrowserInfoCS.Acquire;
|
||||||
|
|
||||||
|
FErrorCode := errorCode;
|
||||||
|
FErrorText := errorText;
|
||||||
|
FFailedUrl := failedUrl;
|
||||||
|
|
||||||
|
PostThreadMessage(ThreadID, CEF_WEBPAGE_ERROR_MSG, 0, 0);
|
||||||
|
finally
|
||||||
|
FBrowserInfoCS.Release;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnLoadingStateChange(Sender: TObject; const browser: ICefBrowser; isLoading, canGoBack, canGoForward: Boolean);
|
||||||
|
begin
|
||||||
|
if not(FClosing) and not(Terminated) and not(isLoading) then
|
||||||
|
PostThreadMessage(ThreadID, CEF_WEBPAGE_LOADED_MSG, 0, 0);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnTextResultAvailable(Sender: TObject; const aText : ustring);
|
||||||
|
begin
|
||||||
|
HTMLcopy := aText;
|
||||||
|
|
||||||
|
if assigned(FOnHTMLAvailable) then
|
||||||
|
begin
|
||||||
|
if FSyncEvents then
|
||||||
|
Synchronize(DoOnHTMLAvailable)
|
||||||
|
else
|
||||||
|
DoOnHTMLAvailable;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Resize;
|
||||||
|
begin
|
||||||
|
if FClosing or Terminated or not(Initialized) then exit;
|
||||||
|
|
||||||
|
if assigned(FResizeCS) and assigned(FBrowserBitmap) then
|
||||||
|
try
|
||||||
|
FResizeCS.Acquire;
|
||||||
|
|
||||||
|
if FResizing then
|
||||||
|
FPendingResize := True
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
FResizing := True;
|
||||||
|
FBrowser.WasResized;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FResizeCS.Release;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.CreateBrowser : boolean;
|
||||||
|
begin
|
||||||
|
Result := (FBrowser <> nil) and FBrowser.CreateBrowser;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.LoadPendingURL;
|
||||||
|
begin
|
||||||
|
if FClosing or Terminated or not(Initialized) then exit;
|
||||||
|
|
||||||
|
if assigned(FBrowserInfoCS) then
|
||||||
|
try
|
||||||
|
FBrowserInfoCS.Acquire;
|
||||||
|
|
||||||
|
if (length(FPendingURL) > 0) then
|
||||||
|
begin
|
||||||
|
FBrowser.LoadURL(FPendingURL);
|
||||||
|
FPendingURL := '';
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FBrowserInfoCS.Release;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.WebpagePostProcessing;
|
||||||
|
begin
|
||||||
|
if FClosing or Terminated then
|
||||||
|
exit;
|
||||||
|
|
||||||
|
if (FDelayMs > 0) then
|
||||||
|
sleep(FDelayMs);
|
||||||
|
|
||||||
|
if assigned(FOnHTMLAvailable) then
|
||||||
|
FBrowser.RetrieveHTML();
|
||||||
|
|
||||||
|
if assigned(FOnSnapshotAvailable) then
|
||||||
|
begin
|
||||||
|
if FSyncEvents then
|
||||||
|
Synchronize(DoOnSnapshotAvailable)
|
||||||
|
else
|
||||||
|
DoOnSnapshotAvailable;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.WebpageError;
|
||||||
|
begin
|
||||||
|
if not(FClosing) and not(Terminated) and assigned(FOnError) then
|
||||||
|
begin
|
||||||
|
if FSyncEvents then
|
||||||
|
Synchronize(DoOnError)
|
||||||
|
else
|
||||||
|
DoOnError;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.CloseBrowser;
|
||||||
|
begin
|
||||||
|
if not(FClosing) and assigned(FBrowser) then
|
||||||
|
begin
|
||||||
|
FClosing := True;
|
||||||
|
FBrowser.CloseBrowser(True);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.DoOnError;
|
||||||
|
begin
|
||||||
|
FOnError(self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.DoOnSnapshotAvailable;
|
||||||
|
begin
|
||||||
|
FOnSnapshotAvailable(self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.DoOnHTMLAvailable;
|
||||||
|
begin
|
||||||
|
FOnHTMLAvailable(self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.InitError;
|
||||||
|
begin
|
||||||
|
ErrorText := 'There was an error initializing the CEF browser.';
|
||||||
|
|
||||||
|
if FSyncEvents then
|
||||||
|
Synchronize(DoOnError)
|
||||||
|
else
|
||||||
|
DoOnError;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Execute;
|
||||||
|
var
|
||||||
|
TempCont : boolean;
|
||||||
|
TempMsg : TMsg;
|
||||||
|
begin
|
||||||
|
if CreateBrowser then
|
||||||
|
begin
|
||||||
|
TempCont := True;
|
||||||
|
PeekMessage(TempMsg, 0, WM_USER, WM_USER, PM_NOREMOVE);
|
||||||
|
|
||||||
|
while TempCont and GetMessage(TempMsg, 0, 0, 0) and not(Terminated) do
|
||||||
|
begin
|
||||||
|
case TempMsg.Message of
|
||||||
|
CEF_PENDINGRESIZE : Resize;
|
||||||
|
CEF_CLOSE_BROWSER_MSG : CloseBrowser;
|
||||||
|
CEF_LOAD_PENDING_URL_MSG : LoadPendingURL;
|
||||||
|
CEF_WEBPAGE_LOADED_MSG : WebpagePostProcessing;
|
||||||
|
CEF_WEBPAGE_ERROR_MSG : WebpageError;
|
||||||
|
WM_QUIT : TempCont := False;
|
||||||
|
end;
|
||||||
|
|
||||||
|
DispatchMessage(TempMsg);
|
||||||
|
end;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
InitError;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
26
demos/Delphi_UniGUI/WebpageSnapshot/uCEFLoader.pas
Normal file
26
demos/Delphi_UniGUI/WebpageSnapshot/uCEFLoader.pas
Normal file
@ -0,0 +1,26 @@
|
|||||||
|
unit uCEFLoader;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
uCEFApplication;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
procedure CreateGlobalCEFApp;
|
||||||
|
begin
|
||||||
|
GlobalCEFApp := TCefApplication.Create;
|
||||||
|
GlobalCEFApp.WindowlessRenderingEnabled := True;
|
||||||
|
GlobalCEFApp.ShowMessageDlg := False;
|
||||||
|
GlobalCEFApp.BrowserSubprocessPath := 'WebpageSnapshotUniGUI_sp.exe'; // This is the other EXE for the CEF subprocesses. It's on the same directory as this app.
|
||||||
|
GlobalCEFApp.BlinkSettings := 'hideScrollbars'; // This setting removes all scrollbars to capture a cleaner snapshot
|
||||||
|
GlobalCEFApp.StartMainProcess;
|
||||||
|
end;
|
||||||
|
|
||||||
|
initialization
|
||||||
|
CreateGlobalCEFApp;
|
||||||
|
|
||||||
|
finalization
|
||||||
|
DestroyGlobalCEFApp;
|
||||||
|
|
||||||
|
end.
|
||||||
@ -2,7 +2,7 @@
|
|||||||
"UpdateLazPackages" : [
|
"UpdateLazPackages" : [
|
||||||
{
|
{
|
||||||
"ForceNotify" : true,
|
"ForceNotify" : true,
|
||||||
"InternalVersion" : 692,
|
"InternalVersion" : 693,
|
||||||
"Name" : "cef4delphi_lazarus.lpk",
|
"Name" : "cef4delphi_lazarus.lpk",
|
||||||
"Version" : "131.4.1"
|
"Version" : "131.4.1"
|
||||||
}
|
}
|
||||||
|
|||||||
Reference in New Issue
Block a user