paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-16 06:09:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL: Add procedure for high-quality image scaling, by Roland Hahn

Browse Source 
git-svn-id: trunk@63766 -
This commit is contained in:
wp 2020-08-17 21:41:42 +00:00
parent 3547e13299
commit 7924956a5a
1 changed files with 22 additions and 0 deletions

22
lcl/graphutil.pp
View File

@ -67,6 +67,7 @@ procedure DrawArrow(Canvas:TCanvas;p1,p2: TPoint; ArrowType: TArrowType=atSolid)
procedure DrawArrow(Canvas:TCanvas;p1,p2: TPoint; ArrowLen: longint; ArrowAngleRad: float=NiceArrowAngle; ArrowType: TArrowType=atSolid);
procedure FloodFill(Canvas: TCanvas; X, Y: Integer; lColor: TColor; FillStyle: TFillStyle);
procedure ScaleImg(AImage: TCustomBitmap; AWidth, AHeight: Integer);
// delphi compatibility
procedure ColorRGBToHLS(clrRGB: COLORREF; var Hue, Luminance, Saturation: Word);
@ -356,6 +357,27 @@ begin //FloodFill
freemem(lQra);
end;
procedure ScaleImg(AImage: TCustomBitmap; AWidth, AHeight: Integer);
var
srcImg: TLazIntfImage = nil;
destCanvas: TLazCanvas = nil;
begin
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);
finally
destCanvas.Free;
srcImg.Free;
end;
end;
procedure ColorRGBToHLS(clrRGB: COLORREF; var Hue, Luminance, Saturation: Word);
var
H, L, S: Byte;