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

lcl: imagelist: add TCustomImageList.AddSlice function. Issue #33114

Browse Source 
git-svn-id: trunk@57207 -
This commit is contained in:
ondrej 2018-02-01 16:59:15 +00:00
parent d67baf1433
commit 5493650684
2 changed files with 26 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
lcl/imglist.pp
View File

@ -296,6 +296,7 @@ type
function Add(Image, Mask: TCustomBitmap): Integer;
function AddSliced(Image: TCustomBitmap; AHorizontalCount, AVerticalCount: Integer): Integer;
function AddSlice(Image: TCustomBitmap; AImageRect: TRect): Integer;
function AddIcon(Image: TCustomIcon): Integer;
procedure AddImages(AValue: TCustomImageList);
function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;

28
lcl/include/imglist.inc
View File

@ -1180,6 +1180,24 @@ begin
Grp.Free;
end;
function TCustomImageList.AddSlice(Image: TCustomBitmap; AImageRect: TRect
): Integer;
var
R: TCustomImageListResolution;
ScBmp: TRGBAQuadArray;
begin
if Image = nil then Exit(-1);
Result := Count;
CreateDefaultResolution;
for R in Resolutions do
begin
ScaleImage(Image, nil, AImageRect, R.Width, R.Height, ScBmp);
R.InternalInsert(Result, @ScBmp[0]);
end;
end;
function TCustomImageList.AddSliced(Image: TCustomBitmap; AHorizontalCount,
AVerticalCount: Integer): Integer;
var
@ -2036,9 +2054,13 @@ begin
for X := SourceRect.Left to SourceRect.Right do
for Y := SourceRect.Top to SourceRect.Bottom do
begin
C := II.Colors[X, Y];
if (AMask<>0) and II.Masked[X, Y] then
C.Alpha := 0;
if (X>=0) and (X<II.Width) and (Y>=0) and (Y<II.Height) then
begin
C := II.Colors[X, Y];
if (AMask<>0) and II.Masked[X, Y] then
C.Alpha := 0;
end else
C := colTransparent;
FI.Colors[X-SourceRect.Left, Y-SourceRect.Top] := C;
end;