pascal/CEF4Delphi
1
0
Fork 0
mirror of https://github.com/salvadordf/CEF4Delphi.git synced 2025-04-07 06:50:04 +02:00
Code Issues Actions Releases Activity

Fixed an issue copying the bitmap in uCEFBrowserThread

Browse Source 
Added more checks to uCEFBrowserThread
This commit is contained in:
Salvador Diaz Fau 2020-12-14 13:27:19 +01:00
parent 1299a6f596
commit 8f88a31440
14 changed files with 1325 additions and 904 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
demos/Delphi_VCL/ConsoleBrowser2/ConsoleBrowser2_sp.dpr
View File

@ -53,6 +53,16 @@ begin
GlobalCEFApp.EnableHighDPISupport := True;
GlobalCEFApp.ShowMessageDlg := False;
GlobalCEFApp.BlinkSettings := 'hideScrollbars';
{
// In case you use a custom directory for the CEF binaries you have to set these properties
// here and in the main process
GlobalCEFApp.FrameworkDirPath := 'c:\cef';
GlobalCEFApp.ResourcesDirPath := 'c:\cef';
GlobalCEFApp.LocalesDirPath := 'c:\cef\locales';
GlobalCEFApp.SetCurrentDir := True;
}
GlobalCEFApp.StartSubProcess;
DestroyGlobalCEFApp;
end.

501
demos/Delphi_VCL/ConsoleBrowser2/uCEFBrowserThread.pas
View File

@ -84,16 +84,19 @@ type
FErrorText : ustring;
FFailedUrl : ustring;
FPendingUrl : ustring;
FSyncEvents : boolean;
function GetErrorCode : integer;
function GetErrorText : ustring;
function GetFailedUrl : ustring;
function GetInitialized : boolean;
procedure SetErrorText(const aValue : ustring);
procedure Panel_OnResize(Sender: TObject);
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; width, height: Integer);
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);
@ -104,13 +107,15 @@ type
procedure Browser_OnLoadError(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; errorCode: Integer; const errorText, failedUrl: ustring);
procedure Browser_OnLoadingStateChange(Sender: TObject; const browser: ICefBrowser; isLoading, canGoBack, canGoForward: Boolean);
procedure DoOnError;
procedure DoOnSnapshotAvailable;
procedure Resize;
function CreateBrowser : boolean;
procedure TakeSnapshot;
function TakeSnapshot : boolean;
procedure CloseBrowser;
procedure DoOnError;
procedure InitError;
procedure WebpagePostProcessing;
procedure WebpageError;
procedure LoadPendingURL;
procedure Execute; override;
@ -124,9 +129,11 @@ type
procedure LoadUrl(const aURL : ustring);
property ErrorCode : integer read GetErrorCode;
property ErrorText : ustring read GetErrorText;
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 OnSnapshotAvailable : TNotifyEvent read FOnSnapshotAvailable write FOnSnapshotAvailable;
property OnError : TNotifyEvent read FOnError write FOnError;
@ -178,6 +185,7 @@ begin
FOnSnapshotAvailable := nil;
FOnError := nil;
FClosing := False;
FSyncEvents := False;
end;
destructor TCEFBrowserThread.Destroy;
@ -234,23 +242,41 @@ end;
function TCEFBrowserThread.GetErrorCode : integer;
begin
FBrowserInfoCS.Acquire;
Result := FErrorCode;
FBrowserInfoCS.Release;
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
Result := FErrorCode;
finally
FBrowserInfoCS.Release;
end
else
Result := 0;
end;
function TCEFBrowserThread.GetErrorText : ustring;
begin
FBrowserInfoCS.Acquire;
Result := FErrorText;
FBrowserInfoCS.Release;
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
Result := FErrorText;
finally
FBrowserInfoCS.Release;
end
else
Result := '';
end;
function TCEFBrowserThread.GetFailedUrl : ustring;
begin
FBrowserInfoCS.Acquire;
Result := FFailedUrl;
FBrowserInfoCS.Release;
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
Result := FFailedUrl;
finally
FBrowserInfoCS.Release;
end
else
Result := '';
end;
function TCEFBrowserThread.GetInitialized : boolean;
@ -266,69 +292,85 @@ begin
end;
end;
procedure TCEFBrowserThread.SetErrorText(const aValue : ustring);
begin
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
FErrorText := aValue;
finally
FBrowserInfoCS.Release;
end;
end;
function TCEFBrowserThread.CopySnapshot(var aSnapshot : TBitmap) : boolean;
begin
Result := False;
if FClosing or Terminated or (FBrowserInfoCS = nil) then exit;
if FClosing or Terminated or not(Initialized) then exit;
try
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
try
FBrowserInfoCS.Acquire;
if assigned(FSnapshot) and not(FSnapshot.Empty) then
begin
if (aSnapshot = nil) then
begin
aSnapshot := TBitmap.Create;
aSnapshot.PixelFormat := pf32bit;
aSnapshot.HandleType := bmDIB;
aSnapshot.Width := FSnapshot.Width;
aSnapshot.Height := FSnapshot.Height;
end;
if assigned(FSnapshot) and not(FSnapshot.Empty) then
begin
if (aSnapshot = nil) then
begin
aSnapshot := TBitmap.Create;
aSnapshot.PixelFormat := pf32bit;
aSnapshot.HandleType := bmDIB;
end;
aSnapshot.Assign(FSnapshot);
Result := True;
end;
except
on e : exception do
if CustomExceptionHandler('TCEFBrowserThread.CopySnapshot', e) then raise;
if (aSnapshot.Width <> FSnapshot.Width) then
aSnapshot.Width := FSnapshot.Width;
if (aSnapshot.Height <> FSnapshot.Height) then
aSnapshot.Height := FSnapshot.Height;
aSnapshot.Canvas.Draw(0, 0, FSnapshot);
Result := True;
end;
except
on e : exception do
if CustomExceptionHandler('TCEFBrowserThread.CopySnapshot', e) then raise;
end;
finally
FBrowserInfoCS.Release;
end;
finally
FBrowserInfoCS.Release;
end;
end;
function TCEFBrowserThread.SaveSnapshotToFile(const aPath : ustring) : boolean;
begin
Result := False;
if (FBrowserInfoCS = nil) then exit;
if FClosing or Terminated or not(Initialized) then exit;
try
if assigned(FBrowserInfoCS) and (length(aPath) > 0) then
try
FBrowserInfoCS.Acquire;
try
FBrowserInfoCS.Acquire;
if assigned(FSnapshot) and not(FSnapshot.Empty) then
begin
FSnapshot.SaveToFile(aPath);
Result := True;
end;
except
on e : exception do
if CustomExceptionHandler('TCEFBrowserThread.SaveSnapshotToFile', e) then raise;
if assigned(FSnapshot) and not(FSnapshot.Empty) then
begin
FSnapshot.SaveToFile(aPath);
Result := True;
end;
except
on e : exception do
if CustomExceptionHandler('TCEFBrowserThread.SaveSnapshotToFile', e) then raise;
end;
finally
FBrowserInfoCS.Release;
end;
finally
FBrowserInfoCS.Release;
end;
end;
procedure TCEFBrowserThread.LoadUrl(const aURL : ustring);
begin
if FClosing or Terminated or (FBrowserInfoCS = nil) then
exit;
if FClosing or Terminated or not(Initialized) then exit;
if Initialized then
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
FPendingUrl := aURL;
@ -351,12 +393,16 @@ end;
procedure TCEFBrowserThread.Browser_OnAfterCreated(Sender: TObject; const browser: ICefBrowser);
begin
FBrowserInfoCS.Acquire;
FInitialized := True;
FBrowserInfoCS.Release;
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; width, height: Integer);
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;
@ -366,112 +412,116 @@ var
TempForcedResize : boolean;
TempSrcRect : TRect;
begin
try
FResizeCS.Acquire;
TempForcedResize := False;
if assigned(FResizeCS) and assigned(FPanel) then
try
FResizeCS.Acquire;
TempForcedResize := False;
if FPanel.BeginBufferDraw then
begin
if (kind = PET_POPUP) then
begin
if (FPopUpBitmap = nil) or
(width <> FPopUpBitmap.Width) or
(height <> FPopUpBitmap.Height) then
begin
if (FPopUpBitmap <> nil) then FPopUpBitmap.Free;
if FPanel.BeginBufferDraw 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 := width;
FPopUpBitmap.Height := height;
end;
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 := FPanel.UpdateBufferDimensions(Width, Height) or not(FPanel.BufferIsResized(False));
TempWidth := FPanel.BufferWidth;
TempHeight := FPanel.BufferHeight;
TempScanlineSize := FPanel.ScanlineSize;
TempBufferBits := FPanel.BufferBits;
end;
TempWidth := FPopUpBitmap.Width;
TempHeight := FPopUpBitmap.Height;
TempScanlineSize := FPopUpBitmap.Width * SizeOf(TRGBQuad);
TempBufferBits := FPopUpBitmap.Scanline[pred(FPopUpBitmap.Height)];
end
else
begin
TempForcedResize := FPanel.UpdateBufferDimensions(aWidth, aHeight) or not(FPanel.BufferIsResized(False));
TempWidth := FPanel.BufferWidth;
TempHeight := FPanel.BufferHeight;
TempScanlineSize := FPanel.ScanlineSize;
TempBufferBits := FPanel.BufferBits;
end;
if (TempBufferBits <> nil) then
begin
SrcStride := Width * SizeOf(TRGBQuad);
DstStride := - TempScanlineSize;
if (TempBufferBits <> nil) then
begin
SrcStride := aWidth * SizeOf(TRGBQuad);
DstStride := - TempScanlineSize;
n := 0;
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);
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 * Width) + dirtyRects[n].x) * SizeOf(TRGBQuad);
TempDstOffset := ((TempScanlineSize * pred(TempHeight)) - (dirtyRects[n].y * TempScanlineSize)) +
(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];
src := @PByte(buffer)[TempSrcOffset];
dst := @PByte(TempBufferBits)[TempDstOffset];
i := 0;
j := min(dirtyRects[n].height, TempHeight - dirtyRects[n].y);
i := 0;
j := min(dirtyRects[n].height, TempHeight - dirtyRects[n].y);
while (i < j) do
begin
Move(src^, dst^, TempLineSize);
while (i < j) do
begin
Move(src^, dst^, TempLineSize);
Inc(dst, DstStride);
Inc(src, SrcStride);
inc(i);
end;
end;
end;
Inc(dst, DstStride);
Inc(src, SrcStride);
inc(i);
end;
end;
end;
inc(n);
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));
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));
FPanel.BufferDraw(FPopUpBitmap, TempSrcRect, FPopUpRect);
end;
end;
FPanel.BufferDraw(FPopUpBitmap, TempSrcRect, FPopUpRect);
end;
end;
FPanel.EndBufferDraw;
FPanel.EndBufferDraw;
if (kind = PET_VIEW) then
begin
if TempForcedResize or FPendingResize then
PostThreadMessage(ThreadID, CEF_PENDINGRESIZE, 0, 0);
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;
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(FPanel.Width, FScreenScale);
rect.height := DeviceToLogical(FPanel.Height, FScreenScale);
if assigned(FPanel) then
begin
rect.x := 0;
rect.y := 0;
rect.width := DeviceToLogical(FPanel.Width, FScreenScale);
rect.height := DeviceToLogical(FPanel.Height, FScreenScale);
end;
end;
procedure TCEFBrowserThread.Browser_OnGetScreenPoint(Sender: TObject; const browser: ICefBrowser; viewX, viewY: Integer; var screenX, screenY: Integer; out Result: Boolean);
@ -485,19 +535,22 @@ procedure TCEFBrowserThread.Browser_OnGetScreenInfo(Sender: TObject; const brows
var
TempRect : TCEFRect;
begin
TempRect.x := 0;
TempRect.y := 0;
TempRect.width := DeviceToLogical(FPanel.Width, FScreenScale);
TempRect.height := DeviceToLogical(FPanel.Height, FScreenScale);
if assigned(FPanel) then
begin
TempRect.x := 0;
TempRect.y := 0;
TempRect.width := DeviceToLogical(FPanel.Width, FScreenScale);
TempRect.height := DeviceToLogical(FPanel.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;
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;
Result := True;
end;
end;
procedure TCEFBrowserThread.Browser_OnPopupShow(Sender: TObject; const browser: ICefBrowser; show: Boolean);
@ -536,7 +589,7 @@ end;
procedure TCEFBrowserThread.Browser_OnLoadError(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; errorCode: Integer; const errorText, failedUrl: ustring);
begin
if not(FClosing) and not(Terminated) and (frame <> nil) and frame.IsValid and frame.IsMain then
if not(FClosing) and not(Terminated) and (frame <> nil) and frame.IsValid and frame.IsMain and assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
@ -558,25 +611,25 @@ end;
procedure TCEFBrowserThread.Resize;
begin
if FClosing or Terminated or (FPanel = nil) or (FResizeCS = nil) or (FBrowser = nil) then
exit;
if FClosing or Terminated or not(Initialized) then exit;
try
FResizeCS.Acquire;
if assigned(FResizeCS) and assigned(FPanel) then
try
FResizeCS.Acquire;
if FResizing then
FPendingResize := True
else
if FPanel.BufferIsResized then
FBrowser.Invalidate(PET_VIEW)
if FResizing then
FPendingResize := True
else
begin
FResizing := True;
FBrowser.WasResized;
end;
finally
FResizeCS.Release;
end;
if FPanel.BufferIsResized then
FBrowser.Invalidate(PET_VIEW)
else
begin
FResizing := True;
FBrowser.WasResized;
end;
finally
FResizeCS.Release;
end;
end;
function TCEFBrowserThread.CreateBrowser : boolean;
@ -586,20 +639,20 @@ end;
procedure TCEFBrowserThread.LoadPendingURL;
begin
if FClosing or Terminated or (FBrowser = nil) or (FBrowserInfoCS = nil) then
exit;
if FClosing or Terminated or not(Initialized) then exit;
try
FBrowserInfoCS.Acquire;
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
if (length(FPendingURL) > 0) then
begin
FBrowser.LoadURL(FPendingURL);
FPendingURL := '';
end;
finally
FBrowserInfoCS.Release;
end;
if (length(FPendingURL) > 0) then
begin
FBrowser.LoadURL(FPendingURL);
FPendingURL := '';
end;
finally
FBrowserInfoCS.Release;
end;
end;
procedure TCEFBrowserThread.WebpagePostProcessing;
@ -610,32 +663,58 @@ begin
if (FDelayMs > 0) then
sleep(FDelayMs);
TakeSnapshot;
if assigned(FOnSnapshotAvailable) then FOnSnapshotAvailable(self);
if TakeSnapshot and assigned(FOnSnapshotAvailable) then
begin
if FSyncEvents then
Synchronize(DoOnSnapshotAvailable)
else
DoOnSnapshotAvailable;
end;
end;
procedure TCEFBrowserThread.TakeSnapshot;
procedure TCEFBrowserThread.WebpageError;
begin
if (FPanel = nil) or (FPanel.Buffer = nil) or (FBrowserInfoCS = nil) then
exit;
if not(FClosing) and not(Terminated) and assigned(FOnError) then
begin
if FSyncEvents then
Synchronize(DoOnError)
else
DoOnError;
end;
end;
try
FBrowserInfoCS.Acquire;
function TCEFBrowserThread.TakeSnapshot : boolean;
begin
Result := False;
if (FSnapshot = nil) then
begin
FSnapshot := TBitmap.Create;
FSnapshot.PixelFormat := pf32bit;
FSnapshot.HandleType := bmDIB;
FSnapshot.Width := FPanel.BufferWidth;
FSnapshot.Height := FPanel.BufferHeight;
end;
if FClosing or Terminated or not(Initialized) then exit;
FSnapshot.Assign(FPanel.Buffer);
finally
FBrowserInfoCS.Release;
end;
if assigned(FBrowserInfoCS) and assigned(FPanel) and FPanel.BeginBufferDraw then
try
FBrowserInfoCS.Acquire;
if assigned(FPanel.Buffer) and not(FPanel.Buffer.Empty) then
begin
if (FSnapshot = nil) then
begin
FSnapshot := TBitmap.Create;
FSnapshot.PixelFormat := pf32bit;
FSnapshot.HandleType := bmDIB;
end;
if (FSnapshot.Width <> FPanel.BufferWidth) then
FSnapshot.Width := FPanel.BufferWidth;
if (FSnapshot.Height <> FPanel.BufferHeight) then
FSnapshot.Height := FPanel.BufferHeight;
FSnapshot.Canvas.Draw(0, 0, FPanel.Buffer);
Result := True;
end;
finally
FBrowserInfoCS.Release;
FPanel.EndBufferDraw;
end;
end;
procedure TCEFBrowserThread.CloseBrowser;
@ -649,16 +728,22 @@ end;
procedure TCEFBrowserThread.DoOnError;
begin
if assigned(FOnError) then
FOnError(self);
FOnError(self);
end;
procedure TCEFBrowserThread.DoOnSnapshotAvailable;
begin
FOnSnapshotAvailable(self);
end;
procedure TCEFBrowserThread.InitError;
begin
FBrowserInfoCS.Acquire;
FErrorText := 'There was an error initializing the CEF browser.';
FBrowserInfoCS.Release;
DoOnError;
ErrorText := 'There was an error initializing the CEF browser.';
if FSyncEvents then
Synchronize(DoOnError)
else
DoOnError;
end;
procedure TCEFBrowserThread.Execute;
@ -678,7 +763,7 @@ begin
CEF_CLOSE_BROWSER_MSG : CloseBrowser;
CEF_LOAD_PENDING_URL_MSG : LoadPendingURL;
CEF_WEBPAGE_LOADED_MSG : WebpagePostProcessing;
CEF_WEBPAGE_ERROR_MSG : DoOnError;
CEF_WEBPAGE_ERROR_MSG : WebpageError;
WM_QUIT : TempCont := False;
end;

18
demos/Delphi_VCL/ConsoleBrowser2/uEncapsulatedBrowser.pas
View File

@ -150,6 +150,16 @@ begin
GlobalCEFApp.BrowserSubprocessPath := 'ConsoleBrowser2_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.OnContextInitialized := GlobalCEFApp_OnContextInitialized;
{
// In case you use a custom directory for the CEF binaries you have to set these properties
// here and in the subprocess
GlobalCEFApp.FrameworkDirPath := 'c:\cef';
GlobalCEFApp.ResourcesDirPath := 'c:\cef';
GlobalCEFApp.LocalesDirPath := 'c:\cef\locales';
GlobalCEFApp.SetCurrentDir := True;
}
GlobalCEFApp.StartMainProcess;
end;
@ -206,17 +216,19 @@ begin
if (length(FThread.FailedUrl) > 0) then
FErrorText := FErrorText + ' - ' + FThread.FailedUrl;
MainAppEvent.SetEvent;
if assigned(MainAppEvent) then
MainAppEvent.SetEvent;
end;
procedure TEncapsulatedBrowser.Thread_OnSnapshotAvailable(Sender: TObject);
begin
// This code is executed in the TCEFBrowserThread thread context while the main application thread is waiting for MainAppEvent.
if not(FThread.SaveSnapshotToFile(FSnapshotPath)) then
if (FThread = nil) or not(FThread.SaveSnapshotToFile(FSnapshotPath)) then
FErrorText := 'There was an error copying the snapshot';
MainAppEvent.SetEvent;
if assigned(MainAppEvent) then
MainAppEvent.SetEvent;
end;
initialization

517
demos/Delphi_VCL/WebpageSnapshot/uCEFBrowserThread.pas
View File

@ -54,7 +54,7 @@ type
protected
FCustomScale : single;
function GetScreenScale : single; override;
function GetScreenScale : single; override;
public
property CustomScale : single read FCustomScale write FCustomScale;
@ -84,16 +84,19 @@ type
FErrorText : ustring;
FFailedUrl : ustring;
FPendingUrl : ustring;
FSyncEvents : boolean;
function GetErrorCode : integer;
function GetErrorText : ustring;
function GetFailedUrl : ustring;
function GetInitialized : boolean;
procedure SetErrorText(const aValue : ustring);
procedure Panel_OnResize(Sender: TObject);
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; width, height: Integer);
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);
@ -108,9 +111,11 @@ type
procedure DoOnSnapshotAvailable;
procedure Resize;
function CreateBrowser : boolean;
procedure TakeSnapshot;
function TakeSnapshot : boolean;
procedure CloseBrowser;
procedure InitError;
procedure WebpagePostProcessing;
procedure WebpageError;
procedure LoadPendingURL;
procedure Execute; override;
@ -120,12 +125,15 @@ type
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;
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 OnSnapshotAvailable : TNotifyEvent read FOnSnapshotAvailable write FOnSnapshotAvailable;
property OnError : TNotifyEvent read FOnError write FOnError;
@ -177,6 +185,7 @@ begin
FOnSnapshotAvailable := nil;
FOnError := nil;
FClosing := False;
FSyncEvents := False;
end;
destructor TCEFBrowserThread.Destroy;
@ -233,23 +242,41 @@ end;
function TCEFBrowserThread.GetErrorCode : integer;
begin
FBrowserInfoCS.Acquire;
Result := FErrorCode;
FBrowserInfoCS.Release;
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
Result := FErrorCode;
finally
FBrowserInfoCS.Release;
end
else
Result := 0;
end;
function TCEFBrowserThread.GetErrorText : ustring;
begin
FBrowserInfoCS.Acquire;
Result := FErrorText;
FBrowserInfoCS.Release;
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
Result := FErrorText;
finally
FBrowserInfoCS.Release;
end
else
Result := '';
end;
function TCEFBrowserThread.GetFailedUrl : ustring;
begin
FBrowserInfoCS.Acquire;
Result := FFailedUrl;
FBrowserInfoCS.Release;
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
Result := FFailedUrl;
finally
FBrowserInfoCS.Release;
end
else
Result := '';
end;
function TCEFBrowserThread.GetInitialized : boolean;
@ -265,45 +292,85 @@ begin
end;
end;
procedure TCEFBrowserThread.SetErrorText(const aValue : ustring);
begin
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
FErrorText := aValue;
finally
FBrowserInfoCS.Release;
end;
end;
function TCEFBrowserThread.CopySnapshot(var aSnapshot : TBitmap) : boolean;
begin
Result := False;
if FClosing or Terminated or (FBrowserInfoCS = nil) then exit;
if FClosing or Terminated or not(Initialized) then exit;
try
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
try
FBrowserInfoCS.Acquire;
if assigned(FSnapshot) and not(FSnapshot.Empty) then
begin
if (aSnapshot = nil) then
begin
aSnapshot := TBitmap.Create;
aSnapshot.PixelFormat := pf32bit;
aSnapshot.HandleType := bmDIB;
aSnapshot.Width := FSnapshot.Width;
aSnapshot.Height := FSnapshot.Height;
end;
if assigned(FSnapshot) and not(FSnapshot.Empty) then
begin
if (aSnapshot = nil) then
begin
aSnapshot := TBitmap.Create;
aSnapshot.PixelFormat := pf32bit;
aSnapshot.HandleType := bmDIB;
end;
aSnapshot.Assign(FSnapshot);
Result := True;
end;
except
on e : exception do
if CustomExceptionHandler('TCEFBrowserThread.CopySnapshot', e) then raise;
if (aSnapshot.Width <> FSnapshot.Width) then
aSnapshot.Width := FSnapshot.Width;
if (aSnapshot.Height <> FSnapshot.Height) then
aSnapshot.Height := FSnapshot.Height;
aSnapshot.Canvas.Draw(0, 0, FSnapshot);
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(FSnapshot) and not(FSnapshot.Empty) then
begin
FSnapshot.SaveToFile(aPath);
Result := True;
end;
except
on e : exception do
if CustomExceptionHandler('TCEFBrowserThread.SaveSnapshotToFile', e) then raise;
end;
finally
FBrowserInfoCS.Release;
end;
finally
FBrowserInfoCS.Release;
end;
end;
procedure TCEFBrowserThread.LoadUrl(const aURL : ustring);
begin
if FClosing or Terminated or (FBrowserInfoCS = nil) then
exit;
if FClosing or Terminated or not(Initialized) then exit;
if Initialized then
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
FPendingUrl := aURL;
@ -326,12 +393,16 @@ end;
procedure TCEFBrowserThread.Browser_OnAfterCreated(Sender: TObject; const browser: ICefBrowser);
begin
FBrowserInfoCS.Acquire;
FInitialized := True;
FBrowserInfoCS.Release;
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; width, height: Integer);
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;
@ -341,112 +412,116 @@ var
TempForcedResize : boolean;
TempSrcRect : TRect;
begin
try
FResizeCS.Acquire;
TempForcedResize := False;
if assigned(FResizeCS) and assigned(FPanel) then
try
FResizeCS.Acquire;
TempForcedResize := False;
if FPanel.BeginBufferDraw then
begin
if (kind = PET_POPUP) then
begin
if (FPopUpBitmap = nil) or
(width <> FPopUpBitmap.Width) or
(height <> FPopUpBitmap.Height) then
begin
if (FPopUpBitmap <> nil) then FPopUpBitmap.Free;
if FPanel.BeginBufferDraw 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 := width;
FPopUpBitmap.Height := height;
end;
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 := FPanel.UpdateBufferDimensions(Width, Height) or not(FPanel.BufferIsResized(False));
TempWidth := FPanel.BufferWidth;
TempHeight := FPanel.BufferHeight;
TempScanlineSize := FPanel.ScanlineSize;
TempBufferBits := FPanel.BufferBits;
end;
TempWidth := FPopUpBitmap.Width;
TempHeight := FPopUpBitmap.Height;
TempScanlineSize := FPopUpBitmap.Width * SizeOf(TRGBQuad);
TempBufferBits := FPopUpBitmap.Scanline[pred(FPopUpBitmap.Height)];
end
else
begin
TempForcedResize := FPanel.UpdateBufferDimensions(aWidth, aHeight) or not(FPanel.BufferIsResized(False));
TempWidth := FPanel.BufferWidth;
TempHeight := FPanel.BufferHeight;
TempScanlineSize := FPanel.ScanlineSize;
TempBufferBits := FPanel.BufferBits;
end;
if (TempBufferBits <> nil) then
begin
SrcStride := Width * SizeOf(TRGBQuad);
DstStride := - TempScanlineSize;
if (TempBufferBits <> nil) then
begin
SrcStride := aWidth * SizeOf(TRGBQuad);
DstStride := - TempScanlineSize;
n := 0;
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);
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 * Width) + dirtyRects[n].x) * SizeOf(TRGBQuad);
TempDstOffset := ((TempScanlineSize * pred(TempHeight)) - (dirtyRects[n].y * TempScanlineSize)) +
(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];
src := @PByte(buffer)[TempSrcOffset];
dst := @PByte(TempBufferBits)[TempDstOffset];
i := 0;
j := min(dirtyRects[n].height, TempHeight - dirtyRects[n].y);
i := 0;
j := min(dirtyRects[n].height, TempHeight - dirtyRects[n].y);
while (i < j) do
begin
Move(src^, dst^, TempLineSize);
while (i < j) do
begin
Move(src^, dst^, TempLineSize);
Inc(dst, DstStride);
Inc(src, SrcStride);
inc(i);
end;
end;
end;
Inc(dst, DstStride);
Inc(src, SrcStride);
inc(i);
end;
end;
end;
inc(n);
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));
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));
FPanel.BufferDraw(FPopUpBitmap, TempSrcRect, FPopUpRect);
end;
end;
FPanel.BufferDraw(FPopUpBitmap, TempSrcRect, FPopUpRect);
end;
end;
FPanel.EndBufferDraw;
FPanel.InvalidatePanel;
FPanel.EndBufferDraw;
if (kind = PET_VIEW) then
begin
if TempForcedResize or FPendingResize then PostThreadMessage(ThreadID, CEF_PENDINGRESIZE, 0, 0);
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;
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(FPanel.Width, FScreenScale);
rect.height := DeviceToLogical(FPanel.Height, FScreenScale);
if assigned(FPanel) then
begin
rect.x := 0;
rect.y := 0;
rect.width := DeviceToLogical(FPanel.Width, FScreenScale);
rect.height := DeviceToLogical(FPanel.Height, FScreenScale);
end;
end;
procedure TCEFBrowserThread.Browser_OnGetScreenPoint(Sender: TObject; const browser: ICefBrowser; viewX, viewY: Integer; var screenX, screenY: Integer; out Result: Boolean);
@ -460,19 +535,22 @@ procedure TCEFBrowserThread.Browser_OnGetScreenInfo(Sender: TObject; const brows
var
TempRect : TCEFRect;
begin
TempRect.x := 0;
TempRect.y := 0;
TempRect.width := DeviceToLogical(FPanel.Width, FScreenScale);
TempRect.height := DeviceToLogical(FPanel.Height, FScreenScale);
if assigned(FPanel) then
begin
TempRect.x := 0;
TempRect.y := 0;
TempRect.width := DeviceToLogical(FPanel.Width, FScreenScale);
TempRect.height := DeviceToLogical(FPanel.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;
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;
Result := True;
end;
end;
procedure TCEFBrowserThread.Browser_OnPopupShow(Sender: TObject; const browser: ICefBrowser; show: Boolean);
@ -511,7 +589,7 @@ end;
procedure TCEFBrowserThread.Browser_OnLoadError(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; errorCode: Integer; const errorText, failedUrl: ustring);
begin
if not(FClosing) and not(Terminated) and (frame <> nil) and frame.IsValid and frame.IsMain then
if not(FClosing) and not(Terminated) and (frame <> nil) and frame.IsValid and frame.IsMain and assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
@ -531,37 +609,27 @@ begin
PostThreadMessage(ThreadID, CEF_WEBPAGE_LOADED_MSG, 0, 0);
end;
procedure TCEFBrowserThread.DoOnError;
begin
FOnError(self);
end;
procedure TCEFBrowserThread.DoOnSnapshotAvailable;
begin
FOnSnapshotAvailable(self);
end;
procedure TCEFBrowserThread.Resize;
begin
if FClosing or Terminated or (FPanel = nil) or (FResizeCS = nil) or (FBrowser = nil) then
exit;
if FClosing or Terminated or not(Initialized) then exit;
try
FResizeCS.Acquire;
if assigned(FResizeCS) and assigned(FPanel) then
try
FResizeCS.Acquire;
if FResizing then
FPendingResize := True
else
if FPanel.BufferIsResized then
FBrowser.Invalidate(PET_VIEW)
if FResizing then
FPendingResize := True
else
begin
FResizing := True;
FBrowser.WasResized;
end;
finally
FResizeCS.Release;
end;
if FPanel.BufferIsResized then
FBrowser.Invalidate(PET_VIEW)
else
begin
FResizing := True;
FBrowser.WasResized;
end;
finally
FResizeCS.Release;
end;
end;
function TCEFBrowserThread.CreateBrowser : boolean;
@ -571,20 +639,20 @@ end;
procedure TCEFBrowserThread.LoadPendingURL;
begin
if FClosing or Terminated or (FBrowser = nil) or (FBrowserInfoCS = nil) then
exit;
if FClosing or Terminated or not(Initialized) then exit;
try
FBrowserInfoCS.Acquire;
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
if (length(FPendingURL) > 0) then
begin
FBrowser.LoadURL(FPendingURL);
FPendingURL := '';
end;
finally
FBrowserInfoCS.Release;
end;
if (length(FPendingURL) > 0) then
begin
FBrowser.LoadURL(FPendingURL);
FPendingURL := '';
end;
finally
FBrowserInfoCS.Release;
end;
end;
procedure TCEFBrowserThread.WebpagePostProcessing;
@ -595,33 +663,58 @@ begin
if (FDelayMs > 0) then
sleep(FDelayMs);
TakeSnapshot;
if assigned(FOnSnapshotAvailable) then
Synchronize(DoOnSnapshotAvailable);
if TakeSnapshot and assigned(FOnSnapshotAvailable) then
begin
if FSyncEvents then
Synchronize(DoOnSnapshotAvailable)
else
DoOnSnapshotAvailable;
end;
end;
procedure TCEFBrowserThread.TakeSnapshot;
procedure TCEFBrowserThread.WebpageError;
begin
if (FPanel = nil) or (FPanel.Buffer = nil) or (FBrowserInfoCS = nil) then
exit;
if not(FClosing) and not(Terminated) and assigned(FOnError) then
begin
if FSyncEvents then
Synchronize(DoOnError)
else
DoOnError;
end;
end;
try
FBrowserInfoCS.Acquire;
function TCEFBrowserThread.TakeSnapshot : boolean;
begin
Result := False;
if (FSnapshot = nil) then
begin
FSnapshot := TBitmap.Create;
FSnapshot.PixelFormat := pf32bit;
FSnapshot.HandleType := bmDIB;
FSnapshot.Width := FPanel.BufferWidth;
FSnapshot.Height := FPanel.BufferHeight;
end;
if FClosing or Terminated or not(Initialized) then exit;
FSnapshot.Assign(FPanel.Buffer);
finally
FBrowserInfoCS.Release;
end;
if assigned(FBrowserInfoCS) and assigned(FPanel) and FPanel.BeginBufferDraw then
try
FBrowserInfoCS.Acquire;
if assigned(FPanel.Buffer) and not(FPanel.Buffer.Empty) then
begin
if (FSnapshot = nil) then
begin
FSnapshot := TBitmap.Create;
FSnapshot.PixelFormat := pf32bit;
FSnapshot.HandleType := bmDIB;
end;
if (FSnapshot.Width <> FPanel.BufferWidth) then
FSnapshot.Width := FPanel.BufferWidth;
if (FSnapshot.Height <> FPanel.BufferHeight) then
FSnapshot.Height := FPanel.BufferHeight;
FSnapshot.Canvas.Draw(0, 0, FPanel.Buffer);
Result := True;
end;
finally
FBrowserInfoCS.Release;
FPanel.EndBufferDraw;
end;
end;
procedure TCEFBrowserThread.CloseBrowser;
@ -633,6 +726,26 @@ begin
end;
end;
procedure TCEFBrowserThread.DoOnError;
begin
FOnError(self);
end;
procedure TCEFBrowserThread.DoOnSnapshotAvailable;
begin
FOnSnapshotAvailable(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;
@ -646,17 +759,19 @@ begin
while TempCont and GetMessage(TempMsg, 0, 0, 0) and not(Terminated) do
begin
case TempMsg.Message of
WM_QUIT : TempCont := False;
CEF_PENDINGRESIZE : Resize;
CEF_CLOSE_BROWSER_MSG : CloseBrowser;
CEF_LOAD_PENDING_URL_MSG : LoadPendingURL;
CEF_WEBPAGE_LOADED_MSG : WebpagePostProcessing;
CEF_WEBPAGE_ERROR_MSG : if assigned(FOnError) then Synchronize(DoOnError);
CEF_WEBPAGE_ERROR_MSG : WebpageError;
WM_QUIT : TempCont := False;
end;
DispatchMessage(TempMsg);
end;
end;
end
else
InitError;
end;
end.

1
demos/Delphi_VCL/WebpageSnapshot/uWebpageSnapshot.pas
View File

@ -115,6 +115,7 @@ begin
FThread := TCEFBrowserThread.Create(AddressEdt.Text, 1024, 768);
FThread.OnError := Thread_OnError;
FThread.OnSnapshotAvailable := Thread_OnSnapshotAvailable;
FThread.SyncEvents := True;
FThread.Start;
end
else

13
demos/Lazarus_Windows/ConsoleBrowser2/ConsoleBrowser2.lps
View File

@ -8,9 +8,8 @@
<Unit0>
<Filename Value="ConsoleBrowser2.lpr"/>
<IsPartOfProject Value="True"/>
<IsVisibleTab Value="True"/>
<TopLine Value="37"/>
<CursorPos X="101" Y="71"/>
<TopLine Value="83"/>
<CursorPos X="45" Y="84"/>
<UsageCount Value="20"/>
<Loaded Value="True"/>
<DefaultSyntaxHighlighter Value="Delphi"/>
@ -18,10 +17,12 @@
<Unit1>
<Filename Value="uEncapsulatedBrowser.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="-1"/>
<TopLine Value="203"/>
<CursorPos X="31" Y="225"/>
<IsVisibleTab Value="True"/>
<EditorIndex Value="1"/>
<TopLine Value="141"/>
<CursorPos X="3" Y="222"/>
<UsageCount Value="20"/>
<Loaded Value="True"/>
<DefaultSyntaxHighlighter Value="Delphi"/>
</Unit1>
<Unit2>

493
demos/Lazarus_Windows/ConsoleBrowser2/uCEFBrowserThread.pas
View File

@ -10,7 +10,7 @@
// For more information about CEF4Delphi visit :
// https://www.briskbard.com/index.php?lang=en&pageid=cef
//
// Copyright © 2020 Salvador Diaz Fau. All rights reserved.
// Copyright © 2020 Salvador Diaz Fau. All rights reserved.
//
// ************************************************************************
// ************ vvvv Original license and comments below vvvv *************
@ -35,7 +35,7 @@
*
*)
unit uCEFBrowserThread;
unit uCEFBrowserThread;
{$MODE Delphi}
@ -86,12 +86,15 @@ type
FErrorText : ustring;
FFailedUrl : ustring;
FPendingUrl : ustring;
FSyncEvents : boolean;
function GetErrorCode : integer;
function GetErrorText : ustring;
function GetFailedUrl : ustring;
function GetInitialized : boolean;
procedure SetErrorText(const aValue : ustring);
procedure Panel_OnResize(Sender: TObject);
procedure Browser_OnAfterCreated(Sender: TObject; const browser: ICefBrowser);
@ -106,13 +109,15 @@ type
procedure Browser_OnLoadError(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; errorCode: Integer; const errorText, failedUrl: ustring);
procedure Browser_OnLoadingStateChange(Sender: TObject; const browser: ICefBrowser; isLoading, canGoBack, canGoForward: Boolean);
procedure DoOnError;
procedure DoOnSnapshotAvailable;
procedure Resize;
function CreateBrowser : boolean;
procedure TakeSnapshot;
function TakeSnapshot : boolean;
procedure CloseBrowser;
procedure DoOnError;
procedure InitError;
procedure WebpagePostProcessing;
procedure WebpageError;
procedure LoadPendingURL;
procedure Execute; override;
@ -126,9 +131,11 @@ type
procedure LoadUrl(const aURL : ustring);
property ErrorCode : integer read GetErrorCode;
property ErrorText : ustring read GetErrorText;
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 OnSnapshotAvailable : TNotifyEvent read FOnSnapshotAvailable write FOnSnapshotAvailable;
property OnError : TNotifyEvent read FOnError write FOnError;
@ -180,6 +187,7 @@ begin
FOnSnapshotAvailable := nil;
FOnError := nil;
FClosing := False;
FSyncEvents := False;
end;
destructor TCEFBrowserThread.Destroy;
@ -236,23 +244,41 @@ end;
function TCEFBrowserThread.GetErrorCode : integer;
begin
FBrowserInfoCS.Acquire;
Result := FErrorCode;
FBrowserInfoCS.Release;
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
Result := FErrorCode;
finally
FBrowserInfoCS.Release;
end
else
Result := 0;
end;
function TCEFBrowserThread.GetErrorText : ustring;
begin
FBrowserInfoCS.Acquire;
Result := FErrorText;
FBrowserInfoCS.Release;
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
Result := FErrorText;
finally
FBrowserInfoCS.Release;
end
else
Result := '';
end;
function TCEFBrowserThread.GetFailedUrl : ustring;
begin
FBrowserInfoCS.Acquire;
Result := FFailedUrl;
FBrowserInfoCS.Release;
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
Result := FFailedUrl;
finally
FBrowserInfoCS.Release;
end
else
Result := '';
end;
function TCEFBrowserThread.GetInitialized : boolean;
@ -268,69 +294,85 @@ begin
end;
end;
procedure TCEFBrowserThread.SetErrorText(const aValue : ustring);
begin
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
FErrorText := aValue;
finally
FBrowserInfoCS.Release;
end;
end;
function TCEFBrowserThread.CopySnapshot(var aSnapshot : TBitmap) : boolean;
begin
Result := False;
if FClosing or Terminated or (FBrowserInfoCS = nil) then exit;
if FClosing or Terminated or not(Initialized) then exit;
try
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
try
FBrowserInfoCS.Acquire;
if assigned(FSnapshot) and not(FSnapshot.Empty) then
begin
if (aSnapshot = nil) then
begin
aSnapshot := TBitmap.Create;
aSnapshot.PixelFormat := pf32bit;
aSnapshot.HandleType := bmDIB;
aSnapshot.Width := FSnapshot.Width;
aSnapshot.Height := FSnapshot.Height;
end;
if assigned(FSnapshot) and not(FSnapshot.Empty) then
begin
if (aSnapshot = nil) then
begin
aSnapshot := TBitmap.Create;
aSnapshot.PixelFormat := pf32bit;
aSnapshot.HandleType := bmDIB;
end;
aSnapshot.Assign(FSnapshot);
Result := True;
end;
except
on e : exception do
if CustomExceptionHandler('TCEFBrowserThread.CopySnapshot', e) then raise;
if (aSnapshot.Width <> FSnapshot.Width) then
aSnapshot.Width := FSnapshot.Width;
if (aSnapshot.Height <> FSnapshot.Height) then
aSnapshot.Height := FSnapshot.Height;
aSnapshot.Canvas.Draw(0, 0, FSnapshot);
Result := True;
end;
except
on e : exception do
if CustomExceptionHandler('TCEFBrowserThread.CopySnapshot', e) then raise;
end;
finally
FBrowserInfoCS.Release;
end;
finally
FBrowserInfoCS.Release;
end;
end;
function TCEFBrowserThread.SaveSnapshotToFile(const aPath : ustring) : boolean;
begin
Result := False;
if (FBrowserInfoCS = nil) then exit;
if FClosing or Terminated or not(Initialized) then exit;
try
if assigned(FBrowserInfoCS) and (length(aPath) > 0) then
try
FBrowserInfoCS.Acquire;
try
FBrowserInfoCS.Acquire;
if assigned(FSnapshot) and not(FSnapshot.Empty) then
begin
FSnapshot.SaveToFile(aPath);
Result := True;
end;
except
on e : exception do
if CustomExceptionHandler('TCEFBrowserThread.SaveSnapshotToFile', e) then raise;
if assigned(FSnapshot) and not(FSnapshot.Empty) then
begin
FSnapshot.SaveToFile(aPath);
Result := True;
end;
except
on e : exception do
if CustomExceptionHandler('TCEFBrowserThread.SaveSnapshotToFile', e) then raise;
end;
finally
FBrowserInfoCS.Release;
end;
finally
FBrowserInfoCS.Release;
end;
end;
procedure TCEFBrowserThread.LoadUrl(const aURL : ustring);
begin
if FClosing or Terminated or (FBrowserInfoCS = nil) then
exit;
if FClosing or Terminated or not(Initialized) then exit;
if Initialized then
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
FPendingUrl := aURL;
@ -353,9 +395,13 @@ end;
procedure TCEFBrowserThread.Browser_OnAfterCreated(Sender: TObject; const browser: ICefBrowser);
begin
FBrowserInfoCS.Acquire;
FInitialized := True;
FBrowserInfoCS.Release;
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);
@ -369,112 +415,116 @@ var
TempBitmap : TBitmap;
TempSrcRect : TRect;
begin
try
FResizeCS.Acquire;
TempForcedResize := False;
if assigned(FResizeCS) and assigned(FPanel) then
try
FResizeCS.Acquire;
TempForcedResize := False;
if FPanel.BeginBufferDraw 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;
if FPanel.BeginBufferDraw 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;
FPopUpBitmap := TBitmap.Create;
FPopUpBitmap.PixelFormat := pf32bit;
FPopUpBitmap.HandleType := bmDIB;
FPopUpBitmap.Width := aWidth;
FPopUpBitmap.Height := aHeight;
end;
TempBitmap := FPopUpBitmap;
TempBitmap.BeginUpdate;
TempBitmap := FPopUpBitmap;
TempBitmap.BeginUpdate;
TempWidth := FPopUpBitmap.Width;
TempHeight := FPopUpBitmap.Height;
end
else
begin
TempForcedResize := FPanel.UpdateBufferDimensions(aWidth, aHeight) or not(FPanel.BufferIsResized(False));
TempWidth := FPopUpBitmap.Width;
TempHeight := FPopUpBitmap.Height;
end
else
begin
TempForcedResize := FPanel.UpdateBufferDimensions(aWidth, aHeight) or not(FPanel.BufferIsResized(False));
TempBitmap := FPanel.Buffer;
TempBitmap.BeginUpdate;
TempBitmap := FPanel.Buffer;
TempBitmap.BeginUpdate;
TempWidth := FPanel.BufferWidth;
TempHeight := FPanel.BufferHeight;
end;
TempWidth := FPanel.BufferWidth;
TempHeight := FPanel.BufferHeight;
end;
SrcStride := aWidth * SizeOf(TRGBQuad);
n := 0;
SrcStride := aWidth * SizeOf(TRGBQuad);
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);
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 := (dirtyRects^[n].x * SizeOf(TRGBQuad));
if (TempLineSize > 0) then
begin
TempSrcOffset := ((dirtyRects^[n].y * aWidth) + dirtyRects^[n].x) * SizeOf(TRGBQuad);
TempDstOffset := (dirtyRects^[n].x * SizeOf(TRGBQuad));
src := @PByte(buffer)[TempSrcOffset];
src := @PByte(buffer)[TempSrcOffset];
i := 0;
j := min(dirtyRects^[n].height, TempHeight - dirtyRects^[n].y);
i := 0;
j := min(dirtyRects^[n].height, TempHeight - dirtyRects^[n].y);
while (i < j) do
begin
TempBufferBits := TempBitmap.Scanline[dirtyRects^[n].y + i];
dst := @PByte(TempBufferBits)[TempDstOffset];
while (i < j) do
begin
TempBufferBits := TempBitmap.Scanline[dirtyRects^[n].y + i];
dst := @PByte(TempBufferBits)[TempDstOffset];
Move(src^, dst^, TempLineSize);
Move(src^, dst^, TempLineSize);
Inc(src, SrcStride);
inc(i);
end;
end;
end;
Inc(src, SrcStride);
inc(i);
end;
end;
end;
inc(n);
end;
inc(n);
end;
TempBitmap.EndUpdate;
TempBitmap.EndUpdate;
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));
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));
FPanel.BufferDraw(FPopUpBitmap, TempSrcRect, FPopUpRect);
end;
FPanel.BufferDraw(FPopUpBitmap, TempSrcRect, FPopUpRect);
end;
FPanel.EndBufferDraw;
FPanel.EndBufferDraw;
if (kind = PET_VIEW) then
begin
if TempForcedResize or FPendingResize then
PostThreadMessage(ThreadID, CEF_PENDINGRESIZE, 0, 0);
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;
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(FPanel.Width, FScreenScale);
rect.height := DeviceToLogical(FPanel.Height, FScreenScale);
if assigned(FPanel) then
begin
rect.x := 0;
rect.y := 0;
rect.width := DeviceToLogical(FPanel.Width, FScreenScale);
rect.height := DeviceToLogical(FPanel.Height, FScreenScale);
end;
end;
procedure TCEFBrowserThread.Browser_OnGetScreenPoint(Sender: TObject; const browser: ICefBrowser; viewX, viewY: Integer; var screenX, screenY: Integer; out Result: Boolean);
@ -488,19 +538,22 @@ procedure TCEFBrowserThread.Browser_OnGetScreenInfo(Sender: TObject; const brows
var
TempRect : TCEFRect;
begin
TempRect.x := 0;
TempRect.y := 0;
TempRect.width := DeviceToLogical(FPanel.Width, FScreenScale);
TempRect.height := DeviceToLogical(FPanel.Height, FScreenScale);
if assigned(FPanel) then
begin
TempRect.x := 0;
TempRect.y := 0;
TempRect.width := DeviceToLogical(FPanel.Width, FScreenScale);
TempRect.height := DeviceToLogical(FPanel.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;
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;
Result := True;
end;
end;
procedure TCEFBrowserThread.Browser_OnPopupShow(Sender: TObject; const browser: ICefBrowser; show: Boolean);
@ -539,7 +592,7 @@ end;
procedure TCEFBrowserThread.Browser_OnLoadError(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; errorCode: Integer; const errorText, failedUrl: ustring);
begin
if not(FClosing) and not(Terminated) and (frame <> nil) and frame.IsValid and frame.IsMain then
if not(FClosing) and not(Terminated) and (frame <> nil) and frame.IsValid and frame.IsMain and assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
@ -561,25 +614,25 @@ end;
procedure TCEFBrowserThread.Resize;
begin
if FClosing or Terminated or (FPanel = nil) or (FResizeCS = nil) or (FBrowser = nil) then
exit;
if FClosing or Terminated or not(Initialized) then exit;
try
FResizeCS.Acquire;
if assigned(FResizeCS) and assigned(FPanel) then
try
FResizeCS.Acquire;
if FResizing then
FPendingResize := True
else
if FPanel.BufferIsResized then
FBrowser.Invalidate(PET_VIEW)
if FResizing then
FPendingResize := True
else
begin
FResizing := True;
FBrowser.WasResized;
end;
finally
FResizeCS.Release;
end;
if FPanel.BufferIsResized then
FBrowser.Invalidate(PET_VIEW)
else
begin
FResizing := True;
FBrowser.WasResized;
end;
finally
FResizeCS.Release;
end;
end;
function TCEFBrowserThread.CreateBrowser : boolean;
@ -589,20 +642,20 @@ end;
procedure TCEFBrowserThread.LoadPendingURL;
begin
if FClosing or Terminated or (FBrowser = nil) or (FBrowserInfoCS = nil) then
exit;
if FClosing or Terminated or not(Initialized) then exit;
try
FBrowserInfoCS.Acquire;
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
if (length(FPendingURL) > 0) then
begin
FBrowser.LoadURL(FPendingURL);
FPendingURL := '';
end;
finally
FBrowserInfoCS.Release;
end;
if (length(FPendingURL) > 0) then
begin
FBrowser.LoadURL(FPendingURL);
FPendingURL := '';
end;
finally
FBrowserInfoCS.Release;
end;
end;
procedure TCEFBrowserThread.WebpagePostProcessing;
@ -613,32 +666,58 @@ begin
if (FDelayMs > 0) then
sleep(FDelayMs);
TakeSnapshot;
if assigned(FOnSnapshotAvailable) then FOnSnapshotAvailable(self);
if TakeSnapshot and assigned(FOnSnapshotAvailable) then
begin
if FSyncEvents then
Synchronize(DoOnSnapshotAvailable)
else
DoOnSnapshotAvailable;
end;
end;
procedure TCEFBrowserThread.TakeSnapshot;
procedure TCEFBrowserThread.WebpageError;
begin
if (FPanel = nil) or (FPanel.Buffer = nil) or (FBrowserInfoCS = nil) then
exit;
if not(FClosing) and not(Terminated) and assigned(FOnError) then
begin
if FSyncEvents then
Synchronize(DoOnError)
else
DoOnError;
end;
end;
try
FBrowserInfoCS.Acquire;
function TCEFBrowserThread.TakeSnapshot : boolean;
begin
Result := False;
if (FSnapshot = nil) then
begin
FSnapshot := TBitmap.Create;
FSnapshot.PixelFormat := pf32bit;
FSnapshot.HandleType := bmDIB;
FSnapshot.Width := FPanel.BufferWidth;
FSnapshot.Height := FPanel.BufferHeight;
end;
if FClosing or Terminated or not(Initialized) then exit;
FSnapshot.Assign(FPanel.Buffer);
finally
FBrowserInfoCS.Release;
end;
if assigned(FBrowserInfoCS) and assigned(FPanel) and FPanel.BeginBufferDraw then
try
FBrowserInfoCS.Acquire;
if assigned(FPanel.Buffer) and not(FPanel.Buffer.Empty) then
begin
if (FSnapshot = nil) then
begin
FSnapshot := TBitmap.Create;
FSnapshot.PixelFormat := pf32bit;
FSnapshot.HandleType := bmDIB;
end;
if (FSnapshot.Width <> FPanel.BufferWidth) then
FSnapshot.Width := FPanel.BufferWidth;
if (FSnapshot.Height <> FPanel.BufferHeight) then
FSnapshot.Height := FPanel.BufferHeight;
FSnapshot.Canvas.Draw(0, 0, FPanel.Buffer);
Result := True;
end;
finally
FBrowserInfoCS.Release;
FPanel.EndBufferDraw;
end;
end;
procedure TCEFBrowserThread.CloseBrowser;
@ -652,16 +731,22 @@ end;
procedure TCEFBrowserThread.DoOnError;
begin
if assigned(FOnError) then
FOnError(self);
FOnError(self);
end;
procedure TCEFBrowserThread.DoOnSnapshotAvailable;
begin
FOnSnapshotAvailable(self);
end;
procedure TCEFBrowserThread.InitError;
begin
FBrowserInfoCS.Acquire;
FErrorText := 'There was an error initializing the CEF browser.';
FBrowserInfoCS.Release;
DoOnError;
ErrorText := 'There was an error initializing the CEF browser.';
if FSyncEvents then
Synchronize(DoOnError)
else
DoOnError;
end;
procedure TCEFBrowserThread.Execute;
@ -681,7 +766,7 @@ begin
CEF_CLOSE_BROWSER_MSG : CloseBrowser;
CEF_LOAD_PENDING_URL_MSG : LoadPendingURL;
CEF_WEBPAGE_LOADED_MSG : WebpagePostProcessing;
CEF_WEBPAGE_ERROR_MSG : DoOnError;
CEF_WEBPAGE_ERROR_MSG : WebpageError;
WM_QUIT : TempCont := False;
end;

18
demos/Lazarus_Windows/ConsoleBrowser2/uEncapsulatedBrowser.pas
View File

@ -152,6 +152,16 @@ begin
GlobalCEFApp.BrowserSubprocessPath := 'ConsoleBrowser2_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.OnContextInitialized := GlobalCEFApp_OnContextInitialized;
{
// In case you use a custom directory for the CEF binaries you have to set these properties
// here and in the subprocess
GlobalCEFApp.FrameworkDirPath := 'c:\cef';
GlobalCEFApp.ResourcesDirPath := 'c:\cef';
GlobalCEFApp.LocalesDirPath := 'c:\cef\locales';
GlobalCEFApp.SetCurrentDir := True;
}
GlobalCEFApp.StartMainProcess;
end;
@ -208,17 +218,19 @@ begin
if (length(FThread.FailedUrl) > 0) then
FErrorText := FErrorText + ' - ' + FThread.FailedUrl;
MainAppEvent.SetEvent;
if assigned(MainAppEvent) then
MainAppEvent.SetEvent;
end;
procedure TEncapsulatedBrowser.Thread_OnSnapshotAvailable(Sender: TObject);
begin
// This code is executed in the TCEFBrowserThread thread context while the main application thread is waiting for MainAppEvent.
if not(FThread.SaveSnapshotToFile(FSnapshotPath)) then
if (FThread = nil) or not(FThread.SaveSnapshotToFile(FSnapshotPath)) then
FErrorText := 'There was an error copying the snapshot';
MainAppEvent.SetEvent;
if assigned(MainAppEvent) then
MainAppEvent.SetEvent;
end;
initialization

2
demos/Lazarus_Windows/WebpageSnapshot/WebpageSnapshot.lpi
View File

@ -47,7 +47,9 @@
<Unit2>
<Filename Value="uWebpageSnapshot.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="WebpageSnapshotFrm"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit2>
</Units>
</ProjectOptions>

112
demos/Lazarus_Windows/WebpageSnapshot/WebpageSnapshot.lps
View File

@ -4,12 +4,12 @@
<PathDelim Value="\"/>
<Version Value="11"/>
<BuildModes Active="Default"/>
<Units Count="6">
<Units Count="8">
<Unit0>
<Filename Value="WebpageSnapshot.lpr"/>
<IsPartOfProject Value="True"/>
<TopLine Value="45"/>
<CursorPos X="37" Y="58"/>
<CursorPos Y="73"/>
<UsageCount Value="23"/>
<Loaded Value="True"/>
<DefaultSyntaxHighlighter Value="Delphi"/>
@ -18,9 +18,9 @@
<Filename Value="uCEFBrowserThread.pas"/>
<IsPartOfProject Value="True"/>
<IsVisibleTab Value="True"/>
<EditorIndex Value="1"/>
<TopLine Value="637"/>
<CursorPos X="70" Y="657"/>
<EditorIndex Value="2"/>
<TopLine Value="471"/>
<CursorPos X="66" Y="483"/>
<UsageCount Value="23"/>
<Loaded Value="True"/>
<DefaultSyntaxHighlighter Value="Delphi"/>
@ -28,11 +28,14 @@
<Unit2>
<Filename Value="uWebpageSnapshot.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="WebpageSnapshotFrm"/>
<HasResources Value="True"/>
<EditorIndex Value="-1"/>
<TopLine Value="139"/>
<CursorPos X="74" Y="162"/>
<ResourceBaseClass Value="Form"/>
<EditorIndex Value="1"/>
<TopLine Value="98"/>
<CursorPos X="71" Y="163"/>
<UsageCount Value="23"/>
<Loaded Value="True"/>
<DefaultSyntaxHighlighter Value="Delphi"/>
</Unit2>
<Unit3>
@ -52,112 +55,89 @@
<Unit5>
<Filename Value="..\..\..\source\uCEFBufferPanel.pas"/>
<EditorIndex Value="-1"/>
<TopLine Value="628"/>
<CursorPos Y="644"/>
<TopLine Value="636"/>
<CursorPos Y="652"/>
<UsageCount Value="10"/>
</Unit5>
<Unit6>
<Filename Value="..\ConsoleBrowser2\uCEFBrowserThread.pas"/>
<EditorIndex Value="-1"/>
<TopLine Value="31"/>
<CursorPos X="17" Y="40"/>
<UsageCount Value="10"/>
<DefaultSyntaxHighlighter Value="Delphi"/>
</Unit6>
<Unit7>
<Filename Value="uCEFBrowserThread_v.pas"/>
<UnitName Value="uCEFBrowserThread"/>
<EditorIndex Value="-1"/>
<TopLine Value="321"/>
<CursorPos Y="338"/>
<UsageCount Value="10"/>
<DefaultSyntaxHighlighter Value="Delphi"/>
</Unit7>
</Units>
<JumpHistory Count="25" HistoryIndex="24">
<JumpHistory Count="15" HistoryIndex="14">
<Position1>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="381" TopLine="361"/>
<Caret Line="348" TopLine="334"/>
</Position1>
<Position2>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="383" TopLine="361"/>
<Caret Line="95" Column="17" TopLine="86"/>
</Position2>
<Position3>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="384" TopLine="361"/>
<Caret Line="326" TopLine="292"/>
</Position3>
<Position4>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="386" TopLine="363"/>
<Caret Line="348" TopLine="334"/>
</Position4>
<Position5>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="388" TopLine="365"/>
<Caret Line="349" TopLine="334"/>
</Position5>
<Position6>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="390" TopLine="367"/>
<Caret Line="351" TopLine="334"/>
</Position6>
<Position7>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="392" TopLine="369"/>
<Caret Line="353" TopLine="334"/>
</Position7>
<Position8>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="394" TopLine="371"/>
<Caret Line="376" TopLine="363"/>
</Position8>
<Position9>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="396" TopLine="373"/>
<Caret Line="378" TopLine="363"/>
</Position9>
<Position10>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="397" TopLine="374"/>
<Caret Line="379" TopLine="363"/>
</Position10>
<Position11>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="398" TopLine="375"/>
<Caret Line="381" TopLine="363"/>
</Position11>
<Position12>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="397" TopLine="375"/>
<Caret Line="382" TopLine="363"/>
</Position12>
<Position13>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="400" TopLine="377"/>
<Caret Line="101" Column="62" TopLine="84"/>
</Position13>
<Position14>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="401" TopLine="378"/>
<Caret Line="515" Column="28" TopLine="397"/>
</Position14>
<Position15>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="403" TopLine="380"/>
<Caret Line="416" Column="50" TopLine="403"/>
</Position15>
<Position16>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="404" TopLine="381"/>
</Position16>
<Position17>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="406" TopLine="383"/>
</Position17>
<Position18>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="595" TopLine="570"/>
</Position18>
<Position19>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="336" Column="203" TopLine="334"/>
</Position19>
<Position20>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="98" Column="191" TopLine="98"/>
</Position20>
<Position21>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="351" Column="65" TopLine="418"/>
</Position21>
<Position22>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="644" TopLine="630"/>
</Position22>
<Position23>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="337" TopLine="333"/>
</Position23>
<Position24>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="651" TopLine="637"/>
</Position24>
<Position25>
<Filename Value="uCEFBrowserThread.pas"/>
<Caret Line="653" TopLine="637"/>
</Position25>
</JumpHistory>
<RunParams>
<FormatVersion Value="2"/>

511
demos/Lazarus_Windows/WebpageSnapshot/uCEFBrowserThread.pas
View File

@ -10,7 +10,7 @@
// For more information about CEF4Delphi visit :
// https://www.briskbard.com/index.php?lang=en&pageid=cef
//
// Copyright © 2020 Salvador Diaz Fau. All rights reserved.
// Copyright © 2020 Salvador Diaz Fau. All rights reserved.
//
// ************************************************************************
// ************ vvvv Original license and comments below vvvv *************
@ -35,7 +35,7 @@
*
*)
unit uCEFBrowserThread;
unit uCEFBrowserThread;
{$MODE Delphi}
@ -47,7 +47,7 @@ uses
{$IFDEF DELPHI16_UP}
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, System.SyncObjs, System.Math,
{$ELSE}
LCLIntf, LCLType, LMessages, Windows, Messages, SysUtils, Classes, Graphics, SyncObjs, Math,
Windows, Messages, SysUtils, Classes, Graphics, SyncObjs, Math,
{$ENDIF}
uCEFChromium, uCEFTypes, uCEFInterfaces, uCEFConstants, uCEFBufferPanel, uCEFChromiumCore, uCEFMiscFunctions;
@ -56,7 +56,7 @@ type
protected
FCustomScale : single;
function GetScreenScale : single; override;
function GetScreenScale : single; override;
public
property CustomScale : single read FCustomScale write FCustomScale;
@ -86,12 +86,15 @@ type
FErrorText : ustring;
FFailedUrl : ustring;
FPendingUrl : ustring;
FSyncEvents : boolean;
function GetErrorCode : integer;
function GetErrorText : ustring;
function GetFailedUrl : ustring;
function GetInitialized : boolean;
procedure SetErrorText(const aValue : ustring);
procedure Panel_OnResize(Sender: TObject);
procedure Browser_OnAfterCreated(Sender: TObject; const browser: ICefBrowser);
@ -110,9 +113,11 @@ type
procedure DoOnSnapshotAvailable;
procedure Resize;
function CreateBrowser : boolean;
procedure TakeSnapshot;
function TakeSnapshot : boolean;
procedure CloseBrowser;
procedure InitError;
procedure WebpagePostProcessing;
procedure WebpageError;
procedure LoadPendingURL;
procedure Execute; override;
@ -122,12 +127,15 @@ type
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;
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 OnSnapshotAvailable : TNotifyEvent read FOnSnapshotAvailable write FOnSnapshotAvailable;
property OnError : TNotifyEvent read FOnError write FOnError;
@ -179,6 +187,7 @@ begin
FOnSnapshotAvailable := nil;
FOnError := nil;
FClosing := False;
FSyncEvents := False;
end;
destructor TCEFBrowserThread.Destroy;
@ -235,23 +244,41 @@ end;
function TCEFBrowserThread.GetErrorCode : integer;
begin
FBrowserInfoCS.Acquire;
Result := FErrorCode;
FBrowserInfoCS.Release;
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
Result := FErrorCode;
finally
FBrowserInfoCS.Release;
end
else
Result := 0;
end;
function TCEFBrowserThread.GetErrorText : ustring;
begin
FBrowserInfoCS.Acquire;
Result := FErrorText;
FBrowserInfoCS.Release;
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
Result := FErrorText;
finally
FBrowserInfoCS.Release;
end
else
Result := '';
end;
function TCEFBrowserThread.GetFailedUrl : ustring;
begin
FBrowserInfoCS.Acquire;
Result := FFailedUrl;
FBrowserInfoCS.Release;
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
Result := FFailedUrl;
finally
FBrowserInfoCS.Release;
end
else
Result := '';
end;
function TCEFBrowserThread.GetInitialized : boolean;
@ -267,45 +294,85 @@ begin
end;
end;
procedure TCEFBrowserThread.SetErrorText(const aValue : ustring);
begin
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
FErrorText := aValue;
finally
FBrowserInfoCS.Release;
end;
end;
function TCEFBrowserThread.CopySnapshot(var aSnapshot : TBitmap) : boolean;
begin
Result := False;
if FClosing or Terminated or (FBrowserInfoCS = nil) then exit;
if FClosing or Terminated or not(Initialized) then exit;
try
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
try
FBrowserInfoCS.Acquire;
if assigned(FSnapshot) and not(FSnapshot.Empty) then
begin
if (aSnapshot = nil) then
begin
aSnapshot := TBitmap.Create;
aSnapshot.PixelFormat := pf32bit;
aSnapshot.HandleType := bmDIB;
aSnapshot.Width := FSnapshot.Width;
aSnapshot.Height := FSnapshot.Height;
end;
if assigned(FSnapshot) and not(FSnapshot.Empty) then
begin
if (aSnapshot = nil) then
begin
aSnapshot := TBitmap.Create;
aSnapshot.PixelFormat := pf32bit;
aSnapshot.HandleType := bmDIB;
end;
aSnapshot.Assign(FSnapshot);
Result := True;
end;
except
on e : exception do
if CustomExceptionHandler('TCEFBrowserThread.CopySnapshot', e) then raise;
if (aSnapshot.Width <> FSnapshot.Width) then
aSnapshot.Width := FSnapshot.Width;
if (aSnapshot.Height <> FSnapshot.Height) then
aSnapshot.Height := FSnapshot.Height;
aSnapshot.Canvas.Draw(0, 0, FSnapshot);
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(FSnapshot) and not(FSnapshot.Empty) then
begin
FSnapshot.SaveToFile(aPath);
Result := True;
end;
except
on e : exception do
if CustomExceptionHandler('TCEFBrowserThread.SaveSnapshotToFile', e) then raise;
end;
finally
FBrowserInfoCS.Release;
end;
finally
FBrowserInfoCS.Release;
end;
end;
procedure TCEFBrowserThread.LoadUrl(const aURL : ustring);
begin
if FClosing or Terminated or (FBrowserInfoCS = nil) then
exit;
if FClosing or Terminated or not(Initialized) then exit;
if Initialized then
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
FPendingUrl := aURL;
@ -328,9 +395,13 @@ end;
procedure TCEFBrowserThread.Browser_OnAfterCreated(Sender: TObject; const browser: ICefBrowser);
begin
FBrowserInfoCS.Acquire;
FInitialized := True;
FBrowserInfoCS.Release;
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);
@ -344,112 +415,116 @@ var
TempBitmap : TBitmap;
TempSrcRect : TRect;
begin
try
FResizeCS.Acquire;
TempForcedResize := False;
if assigned(FResizeCS) and assigned(FPanel) then
try
FResizeCS.Acquire;
TempForcedResize := False;
if FPanel.BeginBufferDraw 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;
if FPanel.BeginBufferDraw 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;
FPopUpBitmap := TBitmap.Create;
FPopUpBitmap.PixelFormat := pf32bit;
FPopUpBitmap.HandleType := bmDIB;
FPopUpBitmap.Width := aWidth;
FPopUpBitmap.Height := aHeight;
end;
TempBitmap := FPopUpBitmap;
TempBitmap.BeginUpdate;
TempBitmap := FPopUpBitmap;
TempBitmap.BeginUpdate;
TempWidth := FPopUpBitmap.Width;
TempHeight := FPopUpBitmap.Height;
end
else
begin
TempForcedResize := FPanel.UpdateBufferDimensions(aWidth, aHeight) or not(FPanel.BufferIsResized(False));
TempWidth := FPopUpBitmap.Width;
TempHeight := FPopUpBitmap.Height;
end
else
begin
TempForcedResize := FPanel.UpdateBufferDimensions(aWidth, aHeight) or not(FPanel.BufferIsResized(False));
TempBitmap := FPanel.Buffer;
TempBitmap.BeginUpdate;
TempBitmap := FPanel.Buffer;
TempBitmap.BeginUpdate;
TempWidth := FPanel.BufferWidth;
TempHeight := FPanel.BufferHeight;
end;
TempWidth := FPanel.BufferWidth;
TempHeight := FPanel.BufferHeight;
end;
SrcStride := aWidth * SizeOf(TRGBQuad);
n := 0;
SrcStride := aWidth * SizeOf(TRGBQuad);
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);
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 := (dirtyRects^[n].x * SizeOf(TRGBQuad));
if (TempLineSize > 0) then
begin
TempSrcOffset := ((dirtyRects^[n].y * aWidth) + dirtyRects^[n].x) * SizeOf(TRGBQuad);
TempDstOffset := (dirtyRects^[n].x * SizeOf(TRGBQuad));
src := @PByte(buffer)[TempSrcOffset];
src := @PByte(buffer)[TempSrcOffset];
i := 0;
j := min(dirtyRects^[n].height, TempHeight - dirtyRects^[n].y);
i := 0;
j := min(dirtyRects^[n].height, TempHeight - dirtyRects^[n].y);
while (i < j) do
begin
TempBufferBits := TempBitmap.Scanline[dirtyRects^[n].y + i];
dst := @PByte(TempBufferBits)[TempDstOffset];
while (i < j) do
begin
TempBufferBits := TempBitmap.Scanline[dirtyRects^[n].y + i];
dst := @PByte(TempBufferBits)[TempDstOffset];
Move(src^, dst^, TempLineSize);
Move(src^, dst^, TempLineSize);
Inc(src, SrcStride);
inc(i);
end;
end;
end;
Inc(src, SrcStride);
inc(i);
end;
end;
end;
inc(n);
end;
inc(n);
end;
TempBitmap.EndUpdate;
TempBitmap.EndUpdate;
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));
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));
FPanel.BufferDraw(FPopUpBitmap, TempSrcRect, FPopUpRect);
end;
FPanel.BufferDraw(FPopUpBitmap, TempSrcRect, FPopUpRect);
end;
FPanel.EndBufferDraw;
FPanel.EndBufferDraw;
if (kind = PET_VIEW) then
begin
if TempForcedResize or FPendingResize then
PostThreadMessage(ThreadID, CEF_PENDINGRESIZE, 0, 0);
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;
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(FPanel.Width, FScreenScale);
rect.height := DeviceToLogical(FPanel.Height, FScreenScale);
if assigned(FPanel) then
begin
rect.x := 0;
rect.y := 0;
rect.width := DeviceToLogical(FPanel.Width, FScreenScale);
rect.height := DeviceToLogical(FPanel.Height, FScreenScale);
end;
end;
procedure TCEFBrowserThread.Browser_OnGetScreenPoint(Sender: TObject; const browser: ICefBrowser; viewX, viewY: Integer; var screenX, screenY: Integer; out Result: Boolean);
@ -463,19 +538,22 @@ procedure TCEFBrowserThread.Browser_OnGetScreenInfo(Sender: TObject; const brows
var
TempRect : TCEFRect;
begin
TempRect.x := 0;
TempRect.y := 0;
TempRect.width := DeviceToLogical(FPanel.Width, FScreenScale);
TempRect.height := DeviceToLogical(FPanel.Height, FScreenScale);
if assigned(FPanel) then
begin
TempRect.x := 0;
TempRect.y := 0;
TempRect.width := DeviceToLogical(FPanel.Width, FScreenScale);
TempRect.height := DeviceToLogical(FPanel.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;
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;
Result := True;
end;
end;
procedure TCEFBrowserThread.Browser_OnPopupShow(Sender: TObject; const browser: ICefBrowser; show: Boolean);
@ -514,7 +592,7 @@ end;
procedure TCEFBrowserThread.Browser_OnLoadError(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; errorCode: Integer; const errorText, failedUrl: ustring);
begin
if not(FClosing) and not(Terminated) and (frame <> nil) and frame.IsValid and frame.IsMain then
if not(FClosing) and not(Terminated) and (frame <> nil) and frame.IsValid and frame.IsMain and assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
@ -534,37 +612,27 @@ begin
PostThreadMessage(ThreadID, CEF_WEBPAGE_LOADED_MSG, 0, 0);
end;
procedure TCEFBrowserThread.DoOnError;
begin
FOnError(self);
end;
procedure TCEFBrowserThread.DoOnSnapshotAvailable;
begin
FOnSnapshotAvailable(self);
end;
procedure TCEFBrowserThread.Resize;
begin
if FClosing or Terminated or (FPanel = nil) or (FResizeCS = nil) or (FBrowser = nil) then
exit;
if FClosing or Terminated or not(Initialized) then exit;
try
FResizeCS.Acquire;
if assigned(FResizeCS) and assigned(FPanel) then
try
FResizeCS.Acquire;
if FResizing then
FPendingResize := True
else
if FPanel.BufferIsResized then
FBrowser.Invalidate(PET_VIEW)
if FResizing then
FPendingResize := True
else
begin
FResizing := True;
FBrowser.WasResized;
end;
finally
FResizeCS.Release;
end;
if FPanel.BufferIsResized then
FBrowser.Invalidate(PET_VIEW)
else
begin
FResizing := True;
FBrowser.WasResized;
end;
finally
FResizeCS.Release;
end;
end;
function TCEFBrowserThread.CreateBrowser : boolean;
@ -574,20 +642,20 @@ end;
procedure TCEFBrowserThread.LoadPendingURL;
begin
if FClosing or Terminated or (FBrowser = nil) or (FBrowserInfoCS = nil) then
exit;
if FClosing or Terminated or not(Initialized) then exit;
try
FBrowserInfoCS.Acquire;
if assigned(FBrowserInfoCS) then
try
FBrowserInfoCS.Acquire;
if (length(FPendingURL) > 0) then
begin
FBrowser.LoadURL(FPendingURL);
FPendingURL := '';
end;
finally
FBrowserInfoCS.Release;
end;
if (length(FPendingURL) > 0) then
begin
FBrowser.LoadURL(FPendingURL);
FPendingURL := '';
end;
finally
FBrowserInfoCS.Release;
end;
end;
procedure TCEFBrowserThread.WebpagePostProcessing;
@ -598,33 +666,58 @@ begin
if (FDelayMs > 0) then
sleep(FDelayMs);
TakeSnapshot;
if assigned(FOnSnapshotAvailable) then
Synchronize(DoOnSnapshotAvailable);
if TakeSnapshot and assigned(FOnSnapshotAvailable) then
begin
if FSyncEvents then
Synchronize(DoOnSnapshotAvailable)
else
DoOnSnapshotAvailable;
end;
end;
procedure TCEFBrowserThread.TakeSnapshot;
procedure TCEFBrowserThread.WebpageError;
begin
if (FPanel = nil) or (FPanel.Buffer = nil) or (FBrowserInfoCS = nil) then
exit;
if not(FClosing) and not(Terminated) and assigned(FOnError) then
begin
if FSyncEvents then
Synchronize(DoOnError)
else
DoOnError;
end;
end;
try
FBrowserInfoCS.Acquire;
function TCEFBrowserThread.TakeSnapshot : boolean;
begin
Result := False;
if (FSnapshot = nil) then
begin
FSnapshot := TBitmap.Create;
FSnapshot.PixelFormat := pf32bit;
FSnapshot.HandleType := bmDIB;
FSnapshot.Width := FPanel.BufferWidth;
FSnapshot.Height := FPanel.BufferHeight;
end;
if FClosing or Terminated or not(Initialized) then exit;
FSnapshot.Assign(FPanel.Buffer);
finally
FBrowserInfoCS.Release;
end;
if assigned(FBrowserInfoCS) and assigned(FPanel) and FPanel.BeginBufferDraw then
try
FBrowserInfoCS.Acquire;
if assigned(FPanel.Buffer) and not(FPanel.Buffer.Empty) then
begin
if (FSnapshot = nil) then
begin
FSnapshot := TBitmap.Create;
FSnapshot.PixelFormat := pf32bit;
FSnapshot.HandleType := bmDIB;
end;
if (FSnapshot.Width <> FPanel.BufferWidth) then
FSnapshot.Width := FPanel.BufferWidth;
if (FSnapshot.Height <> FPanel.BufferHeight) then
FSnapshot.Height := FPanel.BufferHeight;
FSnapshot.Canvas.Draw(0, 0, FPanel.Buffer);
Result := True;
end;
finally
FBrowserInfoCS.Release;
FPanel.EndBufferDraw;
end;
end;
procedure TCEFBrowserThread.CloseBrowser;
@ -636,6 +729,26 @@ begin
end;
end;
procedure TCEFBrowserThread.DoOnError;
begin
FOnError(self);
end;
procedure TCEFBrowserThread.DoOnSnapshotAvailable;
begin
FOnSnapshotAvailable(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;
@ -649,17 +762,19 @@ begin
while TempCont and GetMessage(TempMsg, 0, 0, 0) and not(Terminated) do
begin
case TempMsg.Message of
WM_QUIT : TempCont := False;
CEF_PENDINGRESIZE : Resize;
CEF_CLOSE_BROWSER_MSG : CloseBrowser;
CEF_LOAD_PENDING_URL_MSG : LoadPendingURL;
CEF_WEBPAGE_LOADED_MSG : WebpagePostProcessing;
CEF_WEBPAGE_ERROR_MSG : if assigned(FOnError) then Synchronize(DoOnError);
CEF_WEBPAGE_ERROR_MSG : WebpageError;
WM_QUIT : TempCont := False;
end;
DispatchMessage(TempMsg);
end;
end;
end
else
InitError;
end;
end.

30
demos/Lazarus_Windows/WebpageSnapshot/uWebpageSnapshot.lfm
View File

@ -1,24 +1,24 @@
object WebpageSnapshotFrm: TWebpageSnapshotFrm
Left = 0
Height = 486
Top = 0
Width = 711
Caption = 'Web page snapshot'
ClientHeight = 486
ClientWidth = 711
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
Position = poScreenCenter
OnCloseQuery = FormCloseQuery
OnCreate = FormCreate
PixelsPerInch = 96
Position = poScreenCenter
LCLVersion = '2.0.10.0'
object Image1: TImage
Left = 0
Height = 438
Top = 25
Width = 711
Height = 442
Align = alClient
AutoSize = True
Center = True
@ -26,10 +26,10 @@ object WebpageSnapshotFrm: TWebpageSnapshotFrm
end
object StatusBar1: TStatusBar
Left = 0
Top = 467
Height = 23
Top = 463
Width = 711
Height = 19
Panels = <
Panels = <
item
Width = 1000
end>
@ -37,27 +37,29 @@ object WebpageSnapshotFrm: TWebpageSnapshotFrm
end
object NavigationPnl: TPanel
Left = 0
Height = 25
Top = 0
Width = 711
Height = 25
Align = alTop
BevelOuter = bvNone
ClientHeight = 25
ClientWidth = 711
TabOrder = 1
object GoBtn: TButton
Left = 632
Left = 636
Height = 25
Top = 0
Width = 75
Height = 21
Align = alRight
Caption = 'Go'
TabOrder = 0
OnClick = GoBtnClick
TabOrder = 0
end
object AddressEdt: TEdit
Left = 0
Height = 25
Top = 0
Width = 632
Height = 21
Width = 636
Align = alClient
TabOrder = 1
Text = 'https://www.google.com'

1
demos/Lazarus_Windows/WebpageSnapshot/uWebpageSnapshot.pas
View File

@ -117,6 +117,7 @@ begin
FThread := TCEFBrowserThread.Create(AddressEdt.Text, 1024, 768);
FThread.OnError := Thread_OnError;
FThread.OnSnapshotAvailable := Thread_OnSnapshotAvailable;
FThread.SyncEvents := True;
FThread.Start;
end
else

2
update_CEF4Delphi.json
View File

@ -2,7 +2,7 @@
"UpdateLazPackages" : [
{
"ForceNotify" : true,
"InternalVersion" : 207,
"InternalVersion" : 208,
"Name" : "cef4delphi_lazarus.lpk",
"Version" : "87.1.12.0"
}