Skip to content

Commit 373a19f

Browse files
salvadordfsalvadordf
committed
Added WebpageSnapshot demo for UniGUI
1 parent 38b9b5a commit 373a19f

15 files changed

+3523
-1
lines changed

‎demos/Delphi_UniGUI/WebpageSnapshot/00-DeleteDCUs.bat

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
del /s /q *.dcu
2+
del /s /q *.exe
3+
del /s /q *.res
4+
del /s /q *.rsm
5+
del /s /q *.log
6+
del /s /q *.dsk
7+
del /s /q *.identcache
8+
del /s /q *.stat
9+
del /s /q *.local
10+
del /s /q *.~*
11+
rmdir Win32\Debug
12+
rmdir Win32\Release
13+
rmdir Win32
14+
rmdir Win64\Debug
15+
rmdir Win64\Release
16+
rmdir Win64
17+
rmdir __history
18+
rmdir __recovery

‎demos/Delphi_UniGUI/WebpageSnapshot/Main.dfm

Lines changed: 166 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,166 @@
1+
object MainForm: TMainForm
2+
Left = 0
3+
Top = 0
4+
ClientHeight = 645
5+
ClientWidth = 800
6+
Caption = 'Webpage Snapshot UniGUI'
7+
OnShow = UniFormShow
8+
BorderStyle = bsSingle
9+
OldCreateOrder = False
10+
OnClose = UniFormClose
11+
BorderIcons = [biSystemMenu]
12+
MonitoredKeys.Keys = <>
13+
OnCreate = UniFormCreate
14+
TextHeight = 15
15+
object UniPanel1: TUniPanel
16+
Left = 0
17+
Top = 0
18+
Width = 800
19+
Height = 23
20+
Hint = ''
21+
Align = alTop
22+
TabOrder = 0
23+
BorderStyle = ubsNone
24+
Caption = ''
25+
object AddressCb: TUniComboBox
26+
Left = 0
27+
Top = 0
28+
Width = 725
29+
Height = 23
30+
Hint = ''
31+
Text = 'https://www.google.com'
32+
Items.Strings = (
33+
'https://www.google.com'
34+
35+
'https://www.whatismybrowser.com/detect/what-http-headers-is-my-b' +
36+
'rowser-sending'
37+
'https://www.w3schools.com/js/tryit.asp?filename=tryjs_win_close'
38+
'https://www.w3schools.com/js/tryit.asp?filename=tryjs_alert'
39+
'https://www.w3schools.com/js/tryit.asp?filename=tryjs_loc_assign'
40+
41+
'https://www.w3schools.com/jsref/tryit.asp?filename=tryjsref_styl' +
42+
'e_backgroundcolor'
43+
44+
'https://www.w3schools.com/Tags/tryit.asp?filename=tryhtml_iframe' +
45+
'_name'
46+
47+
'https://www.w3schools.com/tags/tryit.asp?filename=tryhtml5_input' +
48+
'_type_file'
49+
50+
'https://www.w3schools.com/jsref/tryit.asp?filename=tryjsref_stat' +
51+
'e_throw_error'
52+
'https://www.htmlquick.com/es/reference/tags/input-file.html'
53+
54+
'https://developer.mozilla.org/en-US/docs/Web/HTML/Element/input/' +
55+
'file'
56+
57+
'https://developer.mozilla.org/en-US/docs/Web/API/HTMLInputElemen' +
58+
't/webkitdirectory'
59+
'https://www.w3schools.com/html/html5_video.asp'
60+
'http://html5test.com/'
61+
62+
'https://webrtc.github.io/samples/src/content/devices/input-outpu' +
63+
't/'
64+
'https://test.webrtc.org/'
65+
'https://www.browserleaks.com/webrtc'
66+
'https://shaka-player-demo.appspot.com/demo/'
67+
'http://webglsamples.org/'
68+
'https://get.webgl.org/'
69+
'https://www.briskbard.com'
70+
'https://www.youtube.com'
71+
'https://html5demos.com/drag/'
72+
'https://frames-per-second.appspot.com/'
73+
74+
'https://www.sede.fnmt.gob.es/certificados/persona-fisica/verific' +
75+
'ar-estado'
76+
'https://www.kirupa.com/html5/accessing_your_webcam_in_html5.htm'
77+
'https://www.xdumaine.com/enumerateDevices/test/'
78+
79+
'https://dagrs.berkeley.edu/sites/default/files/2020-01/sample.pd' +
80+
'f'
81+
'https://codepen.io/udaymanvar/pen/MWaePBY'
82+
83+
'https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes/acc' +
84+
'ept'
85+
'chrome://version/'
86+
'chrome://net-internals/'
87+
'chrome://tracing/'
88+
'chrome://appcache-internals/'
89+
'chrome://blob-internals/'
90+
'chrome://view-http-cache/'
91+
'chrome://credits/'
92+
'chrome://histograms/'
93+
'chrome://media-internals/'
94+
'chrome://kill'
95+
'chrome://crash'
96+
'chrome://hang'
97+
'chrome://shorthang'
98+
'chrome://gpuclean'
99+
'chrome://gpucrash'
100+
'chrome://gpuhang'
101+
'chrome://extensions-support'
102+
'chrome://process-internals')
103+
ItemIndex = 0
104+
Align = alClient
105+
TabOrder = 1
106+
IconItems = <>
107+
end
108+
object GoBtn: TUniButton
109+
Left = 725
110+
Top = 0
111+
Width = 75
112+
Height = 23
113+
Hint = ''
114+
Caption = 'Go'
115+
Align = alRight
116+
TabOrder = 2
117+
OnClick = GoBtnClick
118+
end
119+
end
120+
object UniStatusBar1: TUniStatusBar
121+
Left = 0
122+
Top = 623
123+
Width = 800
124+
Hint = ''
125+
Panels = <
126+
item
127+
Width = 600
128+
end>
129+
SizeGrip = False
130+
Align = alBottom
131+
ParentColor = False
132+
end
133+
object UniMemo1: TUniMemo
134+
Left = 0
135+
Top = 534
136+
Width = 800
137+
Height = 89
138+
Hint = ''
139+
Align = alBottom
140+
ReadOnly = True
141+
TabOrder = 2
142+
end
143+
object UniCanvas1: TUniCanvas
144+
Left = 0
145+
Top = 23
146+
Width = 800
147+
Height = 511
148+
Hint = ''
149+
Align = alClient
150+
ExplicitLeft = 200
151+
ExplicitTop = 104
152+
ExplicitWidth = 320
153+
ExplicitHeight = 320
154+
end
155+
object UniTimer1: TUniTimer
156+
Interval = 100
157+
ClientEvent.Strings = (
158+
'function(sender)'
159+
'{'
160+
' '
161+
'}')
162+
OnTimer = UniTimer1Timer
163+
Left = 496
164+
Top = 376
165+
end
166+
end

‎demos/Delphi_UniGUI/WebpageSnapshot/Main.pas

Lines changed: 138 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,138 @@
1+
unit Main;
2+
3+
interface
4+
5+
uses
6+
Windows, Messages, SysUtils, Variants, Classes, Graphics,
7+
Controls, Forms, uniGUITypes, uniGUIAbstractClasses,
8+
uniGUIClasses, uniGUIRegClasses, uniGUIForm, uniImage, uniButton,
9+
uniMultiItem, uniComboBox, uniGUIBaseClasses, uniPanel,
10+
uCEFBrowserThread, uniStatusBar, uniMemo, uniTimer, uniCanvas;
11+
12+
type
13+
TMainForm = class(TUniForm)
14+
UniPanel1: TUniPanel;
15+
AddressCb: TUniComboBox;
16+
GoBtn: TUniButton;
17+
UniStatusBar1: TUniStatusBar;
18+
UniMemo1: TUniMemo;
19+
UniCanvas1: TUniCanvas;
20+
UniTimer1: TUniTimer;
21+
procedure UniFormCreate(Sender: TObject);
22+
procedure UniFormClose(Sender: TObject; var Action: TCloseAction);
23+
procedure GoBtnClick(Sender: TObject);
24+
procedure UniFormShow(Sender: TObject);
25+
procedure UniTimer1Timer(Sender: TObject);
26+
private
27+
FThread : TCEFBrowserThread;
28+
FMustRefresh : boolean;
29+
30+
procedure Thread_OnError(Sender: TObject);
31+
procedure Thread_OnSnapshotAvailable(Sender: TObject);
32+
procedure Thread_OnHTMLAvailable(Sender: TObject);
33+
public
34+
{ Public declarations }
35+
end;
36+
37+
function MainForm: TMainForm;
38+
39+
implementation
40+
41+
{$R *.dfm}
42+
43+
uses
44+
uniGUIVars, MainModule, uniGUIApplication,
45+
uCEFApplication;
46+
47+
function MainForm: TMainForm;
48+
begin
49+
Result := TMainForm(UniMainModule.GetFormInstance(TMainForm));
50+
end;
51+
52+
procedure TMainForm.GoBtnClick(Sender: TObject);
53+
begin
54+
UniStatusBar1.Panels[0].Text := 'Loading...';
55+
screen.cursor := crAppStart;
56+
FMustRefresh := False;
57+
58+
if (FThread = nil) then
59+
begin
60+
FThread := TCEFBrowserThread.Create(AddressCb.Text, UniCanvas1.Width, UniCanvas1.Height);
61+
FThread.OnError := Thread_OnError;
62+
FThread.OnSnapshotAvailable := Thread_OnSnapshotAvailable;
63+
FThread.OnHTMLAvailable := Thread_OnHTMLAvailable;
64+
FThread.SyncEvents := True;
65+
FThread.Start;
66+
end
67+
else
68+
FThread.LoadUrl(AddressCb.Text);
69+
end;
70+
71+
procedure TMainForm.UniFormClose(Sender: TObject; var Action: TCloseAction);
72+
begin
73+
if (FThread <> nil) then
74+
begin
75+
if FThread.TerminateBrowserThread then
76+
FThread.WaitFor;
77+
78+
FreeAndNil(FThread);
79+
end;
80+
end;
81+
82+
procedure TMainForm.UniFormCreate(Sender: TObject);
83+
begin
84+
FThread := nil;
85+
end;
86+
87+
procedure TMainForm.UniFormShow(Sender: TObject);
88+
begin
89+
if GlobalCEFApp.GlobalContextInitialized then
90+
UniMemo1.Lines.Add('GlobalCEFApp Initialized')
91+
else
92+
UniMemo1.Lines.Add('Error: ' + GlobalCEFApp.LastErrorMessage);
93+
94+
UniMemo1.Refresh;
95+
end;
96+
97+
procedure TMainForm.UniTimer1Timer(Sender: TObject);
98+
begin
99+
if FMustRefresh then
100+
begin
101+
FMustRefresh := False;
102+
Repaint;
103+
end;
104+
end;
105+
106+
procedure TMainForm.Thread_OnError(Sender: TObject);
107+
begin
108+
UniStatusBar1.Panels[0].Text := 'Error ' + inttostr(FThread.ErrorCode) + ' : ' + FThread.ErrorText + ' - ' + FThread.FailedUrl;
109+
screen.cursor := crDefault;
110+
end;
111+
112+
procedure TMainForm.Thread_OnSnapshotAvailable(Sender: TObject);
113+
var
114+
TempBitmap : TBitmap;
115+
begin
116+
TempBitmap := nil;
117+
screen.cursor := crDefault;
118+
119+
if FThread.CopySnapshot(TempBitmap) then
120+
begin
121+
UniCanvas1.Bitmap.Assign(TempBitmap);
122+
UniStatusBar1.Panels[0].Text := 'Snapshot copied successfully';
123+
TempBitmap.Free;
124+
end
125+
else
126+
UniStatusBar1.Panels[0].Text := 'There was an error copying the snapshot';
127+
end;
128+
129+
procedure TMainForm.Thread_OnHTMLAvailable(Sender: TObject);
130+
begin
131+
UniMemo1.Lines.Add(FThread.HTMLcopy);
132+
FMustRefresh := True;
133+
end;
134+
135+
initialization
136+
RegisterAppFormClass(TMainForm);
137+
138+
end.

‎demos/Delphi_UniGUI/WebpageSnapshot/MainModule.dfm

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
object UniMainModule: TUniMainModule
2+
MonitoredKeys.Keys = <>
3+
Height = 480
4+
Width = 640
5+
end

‎demos/Delphi_UniGUI/WebpageSnapshot/MainModule.pas

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,32 @@
1+
unit MainModule;
2+
3+
interface
4+
5+
uses
6+
uniGUIMainModule, SysUtils, Classes;
7+
8+
type
9+
TUniMainModule = class(TUniGUIMainModule)
10+
private
11+
{ Private declarations }
12+
public
13+
{ Public declarations }
14+
end;
15+
16+
function UniMainModule: TUniMainModule;
17+
18+
implementation
19+
20+
{$R *.dfm}
21+
22+
uses
23+
UniGUIVars, ServerModule, uniGUIApplication;
24+
25+
function UniMainModule: TUniMainModule;
26+
begin
27+
Result := TUniMainModule(UniApplication.UniMainModule)
28+
end;
29+
30+
initialization
31+
RegisterMainModuleClass(TUniMainModule);
32+
end.

‎demos/Delphi_UniGUI/WebpageSnapshot/ServerModule.dfm

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
object UniServerModule: TUniServerModule
2+
TempFolder = 'temp\'
3+
Title = 'New Application'
4+
SuppressErrors = []
5+
Bindings = <>
6+
SSL.SSLOptions.RootCertFile = 'root.pem'
7+
SSL.SSLOptions.CertFile = 'cert.pem'
8+
SSL.SSLOptions.KeyFile = 'key.pem'
9+
SSL.SSLOptions.Method = sslvSSLv23
10+
SSL.SSLOptions.SSLVersions = [sslvTLSv1_1, sslvTLSv1_2]
11+
SSL.SSLOptions.Mode = sslmUnassigned
12+
SSL.SSLOptions.VerifyMode = []
13+
SSL.SSLOptions.VerifyDepth = 0
14+
ConnectionFailureRecovery.ErrorMessage = 'Connection Error'
15+
ConnectionFailureRecovery.RetryMessage = 'Retrying...'
16+
Height = 480
17+
Width = 640
18+
end

0 commit comments

Comments
 (0)