paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-07-09 23:05:58 +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); procedure ScaleImg(AImage: TCustomBitmap; AWidth, AHeight: Integer);
var var
srcImg: TLazIntfImage = nil; srcImg, destImg: TLazIntfImage;
destCanvas: TLazCanvas = nil; destCanvas: TLazCanvas;
begin begin
if (AImage.Width = AWidth) and (AImage.Height = AHeight) then if (AImage.Width = AWidth) and (AImage.Height = AHeight) then
exit; exit;
srcImg := AImage.CreateIntfImage;
destImg := AImage.CreateIntfImage;
try try
// Create the source LazIntfImage destImg.SetSize(AWidth, AHeight);
srcImg := AImage.CreateIntfImage; destCanvas := TLazCanvas.Create(destImg);
// Create the destination LazCanvas try
destCanvas := TLazCanvas.Create(srcImg); if (AWidth > srcImg.Width) and (AHeight > srcImg.Height) then
// Execute the canvas.StretchDraw destCanvas.Interpolation := TFPBaseInterpolation.Create;
destCanvas.StretchDraw(0, 0, AWidth, AHeight, srcImg); destCanvas.StretchDraw(0, 0, AWidth, AHeight, srcImg);
// Reload the stretched image into the CustomBitmap destCanvas.Interpolation.Free;
AImage.LoadFromIntfImage(srcImg); AImage.LoadFromIntfImage(destImg);
AImage.SetSize(AWidth, AHeight); finally
destCanvas.Free;
end;
finally finally
destCanvas.Free; destImg.Free;
srcImg.Free; srcImg.Free;
end; end;
end; end;