paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-05 21:38:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL/Forms: Overload function TCustomForm.GetFormImage with procedure requiring the bitmap as argument. Issue #41140.

Browse Source
This commit is contained in:
wp_xyz 2024-09-14 12:51:05 +02:00
parent f7293e2477
commit 55ac08a505
2 changed files with 12 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
lcl/forms.pp
View File

@ -708,6 +708,7 @@ type
procedure EnsureVisible(AMoveToTop: Boolean = True);
procedure FocusControl(WinControl: TWinControl);
function FormIsUpdating: Boolean; override;
procedure GetFormImage(ABitmap: TCustomBitmap);
function GetFormImage: TBitmap;
function GetRolesForControl(AControl: TControl): TControlRolesForForm;
function GetRealPopupParent: TCustomForm;

17
lcl/include/customform.inc
View File

@ -2709,16 +2709,21 @@ begin
end;
end;
function TCustomForm.GetFormImage: TBitmap;
procedure TCustomForm.GetFormImage(ABitmap: TCustomBitmap);
var
ARect: TRect;
ARect: TRect = (Left:0; Top:0; Right:0; Bottom:0);
begin
ABitmap.SetSize(ClientWidth, ClientHeight);
LCLIntf.GetWindowRect(Handle, ARect);
with GetClientOrigin do
PaintTo(ABitmap.Canvas, ARect.Left - X, ARect.Top - Y);
end;
function TCustomForm.GetFormImage: TBitmap;
begin
Result := TBitmap.Create;
try
Result.SetSize(ClientWidth, ClientHeight);
LCLIntf.GetWindowRect(Handle, ARect);
with GetClientOrigin do
PaintTo(Result.Canvas, ARect.Left - X, ARect.Top - Y);
GetFormImage(Result);
except
Result.Free;
raise;