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

IDEIntf: add ScaleImage so that it can be used outside the unit

Browse Source 
git-svn-id: trunk@54290 -
This commit is contained in:
ondrej 2017-02-27 10:00:09 +00:00
parent 4c5531e408
commit e408c18e8e
1 changed files with 48 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
components/ideintf/ideimagesintf.pas
View File

@ -47,7 +47,9 @@ type
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
function GetScalePercent: Integer; class function GetScalePercent: Integer;
class function ScaleImage(const AImage: TGraphic; out ANewInstance: Boolean;
TargetWidth, TargetHeight: Integer): TGraphic;
function GetImageIndex(ImageSize: Integer; ImageName: String): Integer; function GetImageIndex(ImageSize: Integer; ImageName: String): Integer;
function LoadImage(ImageSize: Integer; ImageName: String): Integer; function LoadImage(ImageSize: Integer; ImageName: String): Integer;
@ -99,7 +101,7 @@ begin
Result := FImages_24; Result := FImages_24;
end; end;
function TIDEImages.GetScalePercent: Integer; class function TIDEImages.GetScalePercent: Integer;
begin begin
if ScreenInfo.PixelsPerInchX <= 120 then if ScreenInfo.PixelsPerInchX <= 120 then
Result := 100 // 100-125% (96-120 DPI): no scaling Result := 100 // 100-125% (96-120 DPI): no scaling
@ -165,8 +167,8 @@ function TIDEImages.LoadImage(ImageSize: Integer; ImageName: String): Integer;
end; end;
function _LoadImage(AList: TCustomImageList): Integer; function _LoadImage(AList: TCustomImageList): Integer;
var var
Grp: TGraphic; Grp, GrpScaled: TGraphic;
Bmp: TBitmap; GrpScaledNewInstance: Boolean;
ScalePercent: Integer; ScalePercent: Integer;
begin begin
ScalePercent := GetScalePercent; ScalePercent := GetScalePercent;
@ -181,28 +183,13 @@ function TIDEImages.LoadImage(ImageSize: Integer; ImageName: String): Integer;
end; end;
Grp := CreateGraphicFromResourceName(HInstance, ImageName); Grp := CreateGraphicFromResourceName(HInstance, ImageName);
if ScalePercent<>100 then GrpScaled := ScaleImage(Grp, GrpScaledNewInstance, AList.Width, AList.Height);
begin try
Bmp := TBitmap.Create; Result := _AddBitmap(AList, GrpScaled);
try finally
{$IFDEF LCLGtk2} if GrpScaledNewInstance then
Bmp.PixelFormat := pf24bit; GrpScaled.Free;
Bmp.Canvas.Brush.Color := clBtnFace; end;
{$ELSE}
Bmp.PixelFormat := pf32bit;
Bmp.Canvas.Brush.Color := TColor($FFFFFFFF);
{$ENDIF}
Bmp.SetSize(AList.Width, AList.Height);
Bmp.Canvas.FillRect(Bmp.Canvas.ClipRect);
Bmp.Canvas.StretchDraw(
Rect(0, 0, MulDiv(Grp.Width, ScalePercent, 100), MulDiv(Grp.Height, ScalePercent, 100)),
Grp);
Result := _AddBitmap(AList, Bmp);
finally
Bmp.Free;
end;
end else
Result := _AddBitmap(AList, Grp);
finally finally
Grp.Free; Grp.Free;
end; end;
@ -244,6 +231,40 @@ begin
Names.AddObject(ImageName, TObject(PtrInt(Result))); Names.AddObject(ImageName, TObject(PtrInt(Result)));
end; end;
class function TIDEImages.ScaleImage(const AImage: TGraphic; out
ANewInstance: Boolean; TargetWidth, TargetHeight: Integer): TGraphic;
var
ScalePercent: Integer;
Bmp: TBitmap;
begin
ANewInstance := False;
ScalePercent := GetScalePercent;
if ScalePercent=100 then
Exit(AImage);
Bmp := TBitmap.Create;
try
Result := Bmp;
ANewInstance := True;
{$IFDEF LCLGtk2}
Bmp.PixelFormat := pf24bit;
Bmp.Canvas.Brush.Color := clBtnFace;
{$ELSE}
Bmp.PixelFormat := pf32bit;
Bmp.Canvas.Brush.Color := TColor($FFFFFFFF);
{$ENDIF}
Bmp.SetSize(TargetWidth, TargetHeight);
Bmp.Canvas.FillRect(Bmp.Canvas.ClipRect);
Bmp.Canvas.StretchDraw(
Rect(0, 0, MulDiv(AImage.Width, ScalePercent, 100), MulDiv(AImage.Height, ScalePercent, 100)),
AImage);
except
FreeAndNil(Result);
ANewInstance := False;
raise;
end;
end;
function IDEImages: TIDEImages; function IDEImages: TIDEImages;
begin begin
if FIDEImages = nil then if FIDEImages = nil then