paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-07-08 16:25:56 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL/GraphUtils: Fix image up-scaling by procedure ScaleImg. Issue #41614.

Browse Source
This commit is contained in:
wp_xyz 2025-05-04 19:15:31 +02:00
parent ba09545f7b
commit 412af2a70b
1 changed files with 16 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
lcl/graphutil.pp
View File

@ -368,24 +368,28 @@ end;
procedure ScaleImg(AImage: TCustomBitmap; AWidth, AHeight: Integer);
var
srcImg: TLazIntfImage = nil;
destCanvas: TLazCanvas = nil;
srcImg, destImg: TLazIntfImage;
destCanvas: TLazCanvas;
begin
if (AImage.Width = AWidth) and (AImage.Height = AHeight) then
exit;
srcImg := AImage.CreateIntfImage;
destImg := AImage.CreateIntfImage;
try
// Create the source LazIntfImage
srcImg := AImage.CreateIntfImage;
// Create the destination LazCanvas
destCanvas := TLazCanvas.Create(srcImg);
// Execute the canvas.StretchDraw
destCanvas.StretchDraw(0, 0, AWidth, AHeight, srcImg);
// Reload the stretched image into the CustomBitmap
AImage.LoadFromIntfImage(srcImg);
AImage.SetSize(AWidth, AHeight);
destImg.SetSize(AWidth, AHeight);
destCanvas := TLazCanvas.Create(destImg);
try
if (AWidth > srcImg.Width) and (AHeight > srcImg.Height) then
destCanvas.Interpolation := TFPBaseInterpolation.Create;
destCanvas.StretchDraw(0, 0, AWidth, AHeight, srcImg);
destCanvas.Interpolation.Free;
AImage.LoadFromIntfImage(destImg);
finally
destCanvas.Free;
end;
finally
destCanvas.Free;
destImg.Free;
srcImg.Free;
end;
end;