pascal/CEF4Delphi
1
0
Fork 0
mirror of https://github.com/salvadordf/CEF4Delphi.git synced 2025-01-03 10:15:38 +02:00
Code Issues Actions Releases Activity

Added TFMXChromium.TakeSnapshot

Browse Source 
- Added TFMXChromium.SaveAsBitmapStream
- Added TChromium.SaveAsBitmapStream
- Fixed bug #253
This commit is contained in:
Salvador Díaz Fau 2020-01-02 20:02:47 +01:00
parent fd1e936198
commit e53cc7ee5d
7 changed files with 321 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
demos/Delphi_FMX/SimpleFMXBrowser/uSimpleFMXBrowser.fmx
View File

@ -8,8 +8,10 @@ object SimpleFMXBrowserFrm: TSimpleFMXBrowserFrm
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnActivate = FormActivate
OnCreate = FormCreate
OnCloseQuery = FormCloseQuery
OnDeactivate = FormDeactivate
OnResize = FormResize
OnShow = FormShow
DesignerMasterStyle = 0
@ -27,22 +29,44 @@ object SimpleFMXBrowserFrm: TSimpleFMXBrowserFrm
object AddressEdt: TEdit
Touch.InteractiveGestures = [LongTap, DoubleTap]
Align = Client
TabOrder = 1
TabOrder = 0
Text = 'https://www.google.com'
Size.Width = 871.000000000000000000
Size.Width = 825.000000000000000000
Size.Height = 25.000000000000000000
Size.PlatformDefault = False
end
object GoBtn: TButton
object Panel1: TPanel
Align = Right
Position.X = 876.000000000000000000
Padding.Left = 5.000000000000000000
Position.X = 830.000000000000000000
Position.Y = 5.000000000000000000
Size.Width = 36.000000000000000000
Size.Width = 82.000000000000000000
Size.Height = 25.000000000000000000
Size.PlatformDefault = False
TabOrder = 0
Text = 'Go'
OnClick = GoBtnClick
TabOrder = 2
object GoBtn: TButton
Align = Left
Position.X = 5.000000000000000000
Size.Width = 36.000000000000000000
Size.Height = 25.000000000000000000
Size.PlatformDefault = False
TabOrder = 0
Text = 'Go'
OnClick = GoBtnClick
end
object Button1: TButton
Align = Right
StyledSettings = [Style, FontColor]
Position.X = 46.000000000000000000
Size.Width = 36.000000000000000000
Size.Height = 25.000000000000000000
Size.PlatformDefault = False
TabOrder = 2
Text = #181
TextSettings.Font.Family = 'Webdings'
TextSettings.Font.Size = 24.000000000000000000
OnClick = Button1Click
end
end
end
object Timer1: TTimer
@ -52,6 +76,10 @@ object SimpleFMXBrowserFrm: TSimpleFMXBrowserFrm
Left = 40
Top = 129
end
object SaveDialog1: TSaveDialog
Left = 40
Top = 192
end
object FMXChromium1: TFMXChromium
OnBeforeContextMenu = FMXChromium1BeforeContextMenu
OnContextMenuCommand = FMXChromium1ContextMenuCommand

104
demos/Delphi_FMX/SimpleFMXBrowser/uSimpleFMXBrowser.pas
View File

@ -57,9 +57,12 @@ type
TSimpleFMXBrowserFrm = class(TForm)
AddressPnl: TPanel;
AddressEdt: TEdit;
GoBtn: TButton;
FMXChromium1: TFMXChromium;
Timer1: TTimer;
Panel1: TPanel;
GoBtn: TButton;
Button1: TButton;
SaveDialog1: TSaveDialog;
procedure GoBtnClick(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormCreate(Sender: TObject);
@ -88,19 +91,32 @@ type
const browser: ICefBrowser; const frame: ICefFrame;
const params: ICefContextMenuParams; commandId: Integer;
eventFlags: Cardinal; out Result: Boolean);
procedure Button1Click(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormDeactivate(Sender: TObject);
protected
// Variables to control when can we destroy the form safely
FCanClose : boolean; // Set to True in TFMXChromium.OnBeforeClose
FClosing : boolean; // Set to True in the CloseQuery event.
// This is a workaround for the issue #253
// https://github.com/salvadordf/CEF4Delphi/issues/253
FOldWindowState : TWindowState;
FMXWindowParent : TFMXWindowParent;
function GetCurrentWindowState : TWindowState;
procedure LoadURL;
procedure ResizeChild;
procedure CreateFMXWindowParent;
procedure ShowFMXWindowParent;
function GetFMXWindowParentRect : System.Types.TRect;
function PostCustomMessage(aMessage : cardinal; wParam : cardinal = 0; lParam : integer = 0) : boolean;
property CurrentWindowState : TWindowState read GetCurrentWindowState;
public
procedure DoBrowserCreated;
procedure DoDestroyParent;
@ -240,6 +256,52 @@ begin
{$ENDIF}
end;
function TSimpleFMXBrowserFrm.GetCurrentWindowState : TWindowState;
var
TempPlacement : TWindowPlacement;
TempHWND : HWND;
begin
// TForm.WindowState is not updated correctly in FMX forms and
// it's not possible to receive WM_SIZE with SIZE_RESTORED so have to
// call the GetWindowPlacement function and handle the form state changes manually.
Result := TWindowState.wsNormal;
TempHWND := FmxHandleToHWND(Handle);
ZeroMemory(@TempPlacement, SizeOf(TWindowPlacement));
TempPlacement.Length := SizeOf(TWindowPlacement);
if GetWindowPlacement(TempHWND, @TempPlacement) then
case TempPlacement.showCmd of
SW_SHOWMAXIMIZED : Result := TWindowState.wsMaximized;
SW_SHOWMINIMIZED : Result := TWindowState.wsMinimized;
end;
end;
procedure TSimpleFMXBrowserFrm.FormActivate(Sender: TObject);
var
TempState : TWindowState;
begin
// This is a workaround for the issue #253
// https://github.com/salvadordf/CEF4Delphi/issues/253
TempState := CurrentWindowState;
if (FOldWindowState <> TempState) then
begin
if (FOldWindowState = TWindowState.wsMinimized) then
ShowFMXWindowParent;
FOldWindowState := TempState;
end;
end;
procedure TSimpleFMXBrowserFrm.FormDeactivate(Sender: TObject);
begin
// This is a workaround for the issue #253
// https://github.com/salvadordf/CEF4Delphi/issues/253
FOldWindowState := CurrentWindowState;
end;
procedure TSimpleFMXBrowserFrm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := FCanClose;
@ -260,6 +322,7 @@ begin
FCanClose := False;
FClosing := False;
FMXWindowParent := nil;
FOldWindowState := TWindowState.wsNormal;
end;
procedure TSimpleFMXBrowserFrm.FormResize(Sender: TObject);
@ -268,10 +331,40 @@ begin
ResizeChild;
end;
function TSimpleFMXBrowserFrm.GetFMXWindowParentRect : System.Types.TRect;
begin
Result.Left := 0;
Result.Top := round(AddressPnl.Height);
Result.Right := ClientWidth - 1;
Result.Bottom := ClientHeight - 1;
end;
procedure TSimpleFMXBrowserFrm.ResizeChild;
begin
if (FMXWindowParent <> nil) then
FMXWindowParent.SetBounds(0, round(AddressPnl.Height), ClientWidth - 1, ClientHeight - 1);
FMXWindowParent.SetBounds(GetFMXWindowParentRect);
end;
procedure TSimpleFMXBrowserFrm.Button1Click(Sender: TObject);
var
TempBitmap : TBitmap;
begin
TempBitmap := nil;
try
SaveDialog1.DefaultExt := 'bmp';
SaveDialog1.Filter := 'Bitmap files (*.bmp)|*.BMP';
if SaveDialog1.Execute and (length(SaveDialog1.FileName) > 0) then
begin
TempBitmap := TBitmap.Create;
if FMXChromium1.TakeSnapshot(TempBitmap, GetFMXWindowParentRect) then
TempBitmap.SaveToFile(SaveDialog1.FileName);
end;
finally
if (TempBitmap <> nil) then FreeAndNil(TempBitmap);
end;
end;
procedure TSimpleFMXBrowserFrm.CreateFMXWindowParent;
@ -364,6 +457,13 @@ begin
if (FMXWindowParent <> nil) then FreeAndNil(FMXWindowParent);
end;
procedure TSimpleFMXBrowserFrm.ShowFMXWindowParent;
begin
// This is a workaround for the issue #253
// https://github.com/salvadordf/CEF4Delphi/issues/253
if (FMXWindowParent <> nil) then FMXWindowParent.Show;
end;
procedure TSimpleFMXBrowserFrm.LoadURL;
begin
FMXChromium1.LoadURL(AddressEdt.Text);

62
source/uCEFChromium.pas
View File

@ -83,6 +83,7 @@ type
procedure SetFormTopTo(const y : Integer);
function CreateBrowser(const aBrowserParent : TWinControl = nil; const aWindowName : ustring = ''; const aContext : ICefRequestContext = nil; const aExtraInfo : ICefDictionaryValue = nil) : boolean; overload; virtual;
function SaveAsBitmapStream(var aStream : TStream) : boolean;
function TakeSnapshot(var aBitmap : TBitmap) : boolean;
end;
@ -289,10 +290,34 @@ begin
Result := inherited CreateBrowser(TempHandle, TempRect, aWindowName, aContext, aExtraInfo);
end;
function TChromium.SaveAsBitmapStream(var aStream : TStream) : boolean;
{$IFDEF MSWINDOWS}
var
TempDC : HDC;
TempRect : TRect;
{$ENDIF}
begin
Result := False;
{$IFDEF MSWINDOWS}
if not(FIsOSR) and (FRenderCompHWND <> 0) and (aStream <> nil) then
begin
TempDC := GetDC(FRenderCompHWND);
if (TempDC <> 0) then
try
GetClientRect(FRenderCompHWND, TempRect);
Result := CopyDCToBitmapStream(TempDC, TempRect, aStream);
finally
ReleaseDC(FRenderCompHWND, TempDC);
end;
end;
{$ENDIF}
end;
function TChromium.TakeSnapshot(var aBitmap : TBitmap) : boolean;
{$IFDEF MSWINDOWS}
var
TempHWND : HWND;
TempDC : HDC;
TempRect : TRect;
TempWidth : Integer;
@ -302,30 +327,29 @@ begin
Result := False;
{$IFDEF MSWINDOWS}
if not(FIsOSR) then
if not(FIsOSR) and (FRenderCompHWND <> 0) then
begin
TempHWND := GetWindowHandle;
GetClientRect(FRenderCompHWND, TempRect);
if (TempHWND <> 0) then
begin
GetClientRect(TempHWND, TempRect);
TempWidth := TempRect.Right - TempRect.Left;
TempHeight := TempRect.Bottom - TempRect.Top;
TempWidth := TempRect.Right - TempRect.Left;
TempHeight := TempRect.Bottom - TempRect.Top;
if (TempWidth <= 0) or (TempHeight <= 0) then exit;
if (aBitmap <> nil) then FreeAndNil(aBitmap);
if (aBitmap <> nil) then FreeAndNil(aBitmap);
aBitmap := TBitmap.Create;
aBitmap.Height := TempHeight;
aBitmap.Width := TempWidth;
aBitmap := TBitmap.Create;
aBitmap.Height := TempHeight;
aBitmap.Width := TempWidth;
TempDC := GetDC(TempHWND);
try
Result := BitBlt(aBitmap.Canvas.Handle, 0, 0, TempWidth, TempHeight,
TempDC, 0, 0, SRCCOPY);
finally
ReleaseDC(TempHWND, TempDC);
end;
TempDC := GetDC(FRenderCompHWND);
if (TempDC <> 0) then
try
Result := BitBlt(aBitmap.Canvas.Handle, 0, 0, TempWidth, TempHeight,
TempDC, 0, 0, SRCCOPY);
finally
ReleaseDC(FRenderCompHWND, TempDC);
end;
end;
{$ENDIF}

96
source/uCEFChromiumCore.pas
View File

@ -390,6 +390,7 @@ type
procedure BrowserCompWndProc(var aMessage: TMessage);
procedure WidgetCompWndProc(var aMessage: TMessage);
procedure RenderCompWndProc(var aMessage: TMessage);
function CopyDCToBitmapStream(aSrcDC : HDC; const aSrcRect : TRect; var aStream : TStream) : boolean;
{$ENDIF}
procedure DragDropManager_OnDragEnter(Sender: TObject; const aDragData : ICefDragData; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint);
@ -4928,26 +4929,28 @@ begin
begin
{$IFDEF MSWINDOWS}
OldBrowserCompHWND := FBrowserCompHWND;
OldWidgetCompHWND := FWidgetCompHWND;
OldRenderCompHWND := FRenderCompHWND;
OldWidgetCompHWND := FWidgetCompHWND;
OldRenderCompHWND := FRenderCompHWND;
{$ENDIF}
FBrowserCompHWND := browser.Host.WindowHandle;
{$IFDEF MSWINDOWS}
if (FBrowserCompHWND <> 0) then
begin
FWidgetCompHWND := FindWindowEx(FBrowserCompHWND, 0, 'Chrome_WidgetWin_0', '');
if (FWidgetCompHWND = 0) and FIsOSR and CefCurrentlyOn(TID_UI) then
begin
// The WidgetCompHWND window doesn't have a HwndParent (Owner). If we are in OSR mode this
// causes popup menus that are opened by CEF to stay open if the user clicks somewhere else.
// With this code we search for the Widget window in the UI Thread's window list and set
// the Browser window as its HwndParent. This works around the bug.
EnumThreadWindows(GetCurrentThreadId, @EnumProcOSRChromeWidgetWin0, NativeInt(@FWidgetCompHWND));
if FWidgetCompHWND <> 0 then
SetWindowLongPtr(FWidgetCompHWND, GWLP_HWNDPARENT, NativeInt(FBrowserCompHWND));
FWidgetCompHWND := FindWindowEx(FBrowserCompHWND, 0, 'Chrome_WidgetWin_0', '');
if (FWidgetCompHWND = 0) and FIsOSR and CefCurrentlyOn(TID_UI) then
begin
// The WidgetCompHWND window doesn't have a HwndParent (Owner). If we are in OSR mode this
// causes popup menus that are opened by CEF to stay open if the user clicks somewhere else.
// With this code we search for the Widget window in the UI Thread's window list and set
// the Browser window as its HwndParent. This works around the bug.
EnumThreadWindows(GetCurrentThreadId, @EnumProcOSRChromeWidgetWin0, NativeInt(@FWidgetCompHWND));
if (FWidgetCompHWND <> 0) then
SetWindowLongPtr(FWidgetCompHWND, GWLP_HWNDPARENT, NativeInt(FBrowserCompHWND));
end;
end;
end;
if (FWidgetCompHWND <> 0) then
FRenderCompHWND := FindWindowEx(FWidgetCompHWND, 0, 'Chrome_RenderWidgetHostHWND', 'Chrome Legacy Window');
@ -5389,4 +5392,71 @@ begin
if Initialized then FBrowser.Host.IMECancelComposition;
end;
{$IFDEF MSWINDOWS}
function TChromiumCore.CopyDCToBitmapStream(aSrcDC : HDC; const aSrcRect : TRect; var aStream : TStream) : boolean;
var
TempDstDC : HDC;
TempWidth : Integer;
TempHeight : Integer;
TempInfo : TBitmapInfo;
TempBits : Pointer;
TempNewBitmap : HBITMAP;
TempOldBitmap : HBITMAP;
TempHeader : TBitmapFileHeader;
begin
Result := False;
if (aSrcDC = 0) or (aStream = nil) then exit;
TempDstDC := CreateCompatibleDC(aSrcDC);
if (TempDstDC = 0) then exit;
TempWidth := aSrcRect.Right - aSrcRect.Left;
TempHeight := aSrcRect.Bottom - aSrcRect.Top;
TempBits := nil;
if (TempWidth > 0) and (TempHeight > 0) then
begin
ZeroMemory(@TempInfo, SizeOf(TBitmapInfo));
ZeroMemory(@TempHeader, SizeOf(TBitmapFileHeader));
TempInfo.bmiHeader.biSize := SizeOf(TBitmapInfoHeader);
TempInfo.bmiHeader.biWidth := TempWidth;
TempInfo.bmiHeader.biHeight := TempHeight;
TempInfo.bmiHeader.biPlanes := 1;
TempInfo.bmiHeader.biBitCount := 32;
TempInfo.bmiHeader.biCompression := BI_RGB;
TempInfo.bmiHeader.biSizeImage := TempWidth * TempHeight * SizeOf(TRGBQuad);
TempNewBitmap := CreateDIBSection(TempDstDC, TempInfo, DIB_RGB_COLORS, TempBits, 0, 0);
if (TempNewBitmap <> 0) then
try
TempOldBitmap := SelectObject(TempDstDC, TempNewBitmap);
if BitBlt(TempDstDC, 0, 0, TempWidth, TempHeight, aSrcDC, aSrcRect.Left, aSrcRect.Top, SRCCOPY) then
begin
TempHeader.bfType := $4D42; // "BM" bitmap header
TempHeader.bfOffBits := sizeof(BITMAPFILEHEADER) + TempInfo.bmiHeader.biSize + TempInfo.bmiHeader.biClrUsed * SizeOf(TRGBQuad);
TempHeader.bfSize := TempHeader.bfOffBits + TempInfo.bmiHeader.biSizeImage;
aStream.position := 0;
aStream.Write(TempHeader, SizeOf(TBitmapFileHeader));
aStream.Write(TempInfo.bmiHeader, SizeOf(TBitmapInfoHeader));
aStream.Write(TempBits^, TempInfo.bmiHeader.biSizeImage);
aStream.position := 0;
Result := True;
end;
SelectObject(TempDstDC, TempOldBitmap);
finally
DeleteObject(TempNewBitmap);
end;
end;
ReleaseDC(0, TempDstDC);
end;
{$ENDIF}
end.

52
source/uCEFFMXChromium.pas
View File

@ -49,7 +49,7 @@ uses
{$IFDEF MSWINDOWS}
WinApi.Windows, WinApi.Messages, FMX.Platform.Win,
{$ENDIF}
FMX.Types, FMX.Platform, FMX.Forms, FMX.Controls,
FMX.Types, FMX.Platform, FMX.Forms, FMX.Controls, FMX.Graphics,
uCEFTypes, uCEFInterfaces, uCEFChromiumCore;
type
@ -70,6 +70,8 @@ type
procedure SetFormTopTo(const y : Integer);
function CreateBrowser(const aWindowName : ustring = ''; const aContext : ICefRequestContext = nil; const aExtraInfo : ICefDictionaryValue = nil) : boolean; overload; virtual;
function SaveAsBitmapStream(var aStream : TStream; const aRect : System.Types.TRect) : boolean;
function TakeSnapshot(var aBitmap : TBitmap; const aRect : System.Types.TRect) : boolean;
end;
// *********************************************************
@ -251,4 +253,52 @@ begin
{$ENDIF}
end;
function TFMXChromium.SaveAsBitmapStream(var aStream : TStream; const aRect : System.Types.TRect) : boolean;
{$IFDEF MSWINDOWS}
var
TempDC : HDC;
TempRect : System.Types.TRect;
{$ENDIF}
begin
Result := False;
{$IFDEF MSWINDOWS}
if not(FIsOSR) and (FRenderCompHWND <> 0) and (aStream <> nil) then
begin
TempDC := GetDC(FRenderCompHWND);
if (TempDC <> 0) then
try
TempRect := aRect;
Result := OffsetRect(TempRect, - TempRect.Left, - TempRect.Top) and
CopyDCToBitmapStream(TempDC, TempRect, aStream);
finally
ReleaseDC(FRenderCompHWND, TempDC);
end;
end;
{$ENDIF}
end;
function TFMXChromium.TakeSnapshot(var aBitmap : TBitmap; const aRect : System.Types.TRect) : boolean;
var
TempStream : TMemoryStream;
begin
Result := False;
TempStream := nil;
if FIsOSR or (aBitmap = nil) then exit;
try
TempStream := TMemoryStream.Create;
if SaveAsBitmapStream(TStream(TempStream), aRect) then
begin
aBitmap.LoadFromStream(TempStream);
Result := True;
end;
finally
FreeAndNil(TempStream);
end;
end;
end.

8
source/uCEFMiscFunctions.pas
View File

@ -250,6 +250,8 @@ function MoveFileList(const aFileList : TStringList; const aSrcDirectory, aDstDi
function CefGetDataURI(const aString, aMimeType : ustring) : ustring; overload;
function CefGetDataURI(aData : pointer; aSize : integer; const aMimeType : ustring; const aCharset : ustring = '') : ustring; overload;
implementation
uses
@ -1993,7 +1995,7 @@ begin
if ((aDragOperations and DRAG_OPERATION_COPY) <> 0) then aEffect := aEffect or DROPEFFECT_COPY;
if ((aDragOperations and DRAG_OPERATION_LINK) <> 0) then aEffect := aEffect or DROPEFFECT_LINK;
if ((aDragOperations and DRAG_OPERATION_MOVE) <> 0) then aEffect := aEffect or DROPEFFECT_MOVE;
end;
end;
{$ENDIF}
function DeviceToLogical(aValue : integer; const aDeviceScaleFactor : double) : integer;
@ -2174,5 +2176,5 @@ begin
Result := Result + ';base64,' + CefURIEncode(CefBase64Encode(aData, aSize), false);
end;
end.
end.

2
update_CEF4Delphi.json
View File

@ -2,7 +2,7 @@
"UpdateLazPackages" : [
{
"ForceNotify" : true,
"InternalVersion" : 77,
"InternalVersion" : 78,
"Name" : "cef4delphi_lazarus.lpk",
"Version" : "79.0.10.0"
}