paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-13 17:59:09 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch from Werner Pamler to implement FillEllipsePattern. Fixes issue #40282

Browse Source
This commit is contained in:
Michaël Van Canneyt 2023-05-22 22:46:43 +02:00
parent be54d40660
commit 02b6e9143a
1 changed files with 29 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
packages/fcl-image/src/ellipses.pp
View File

@ -489,7 +489,36 @@ begin
end;
procedure FillEllipsePattern (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TBrushPattern; const c:TFPColor);
var info : TEllipseInfo;
r, y : integer;
pixNo: Byte;
pixVal: TPenPattern;
patt: TPenPattern;
pattHeight: Integer;
infoData: PEllipseInfoData;
begin
info := TEllipseInfo.Create;
try
info.GatherEllipseInfo(bounds);
pattHeight := Length(Pattern);
for r := 0 to info.infolist.count-1 do
begin
infoData := PEllipseInfoData(info.infolist[r]);
with infoData^ do
begin
pixNo := x mod PatternBitCount;
pixVal := 1 shl pixNo;
for y := ytopmin to ybotmax do
begin
patt := Pattern[y mod pattHeight];
if patt and pixVal <> 0 then
canv.DrawPixel(x, y, c);
end;
end;
end;
finally
info.Free;
end;
end;
procedure FillEllipseHashHorizontal (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);