procedure LinienFettierer(Image: TBitmap; Background: TColor; Colors:
Array of TColor; Size: Integer);
type
TRGBA =
packed Record R, G, B, A: Byte;
End;
TScanArray =
packed Array[0..0]
of TRGBA;
PScanArray = ^TScanArray;
var
x, y, x2, y2, x3, y3, i: Integer;
C: TRGBA;
Temp: TBitmap;
Mask:
Array of Array of Boolean;
Scan:
Array of PScanArray;
Scan2: PScanArray;
label
break;
begin
Background := ColorToRGB(Background)
and $00FFFFFF;
for i := 0
to High(Colors)
do
Colors[i] := ColorToRGB(Colors[i])
and $00FFFFFF;
Temp := TBitmap.Create;
try
Image.PixelFormat := pf32bit;
Temp.PixelFormat := pf32bit;
Temp.Width := Image.Width + Size - 1;
Temp.Height := Image.Height + Size - 1;
Temp.Canvas.Brush.Color := clBlack;
Temp.Canvas.Ellipse(0, 0, Size, Size);
Temp.Canvas.Pixels[Size
div 2, Size
div 2] := clBlack;
SetLength(Mask, Size, Size);
for x := 0
to Size - 1
do
for y := 0
to Size - 1
do
Mask[x, y] := Temp.Canvas.Pixels[x, y] = clBlack;
SetLength(Scan, Size);
for y := 0
to Temp.Height - 1
do
begin
for y2 := 0
to Size - 1
do
begin
y3 := y - Size + 1 + y2;
if (y3 >= 0)
and (y3 < Image.Height)
then
Scan[y2] := Image.ScanLine[y3]
else Scan[y2] :=
nil;
end;
Scan2 := Temp.ScanLine[y];
for x := 0
to Temp.Width - 1
do
begin
for i := 0
to Length(Colors)
do
for y2 := 0
to Size - 1
do
begin
y3 := y - Size + 1 + y2;
if (y3 >= 0)
and (y3 < Image.Height)
then
for x2 := 0
to Size - 1
do
begin
x3 := x - Size + 1 + x2;
if (x3 >= 0)
and (x3 < Image.Width)
and Mask[x2, y2]
then
begin
C := Scan[y2][x3];
if ((i < Length(Colors))
and (TColor(C) = Colors[i]))
or ((i = Length(Colors))
and (TColor(C) <> Background))
then
begin
Scan2[x] := TRGBA(
RGB(C.R, C.G, C.B));
goto break;
end;
end;
end;
end;
Scan2[x] := TRGBA(Background);
break:
end;
end;
Image.Width := Temp.Width;
Image.Height := Temp.Height;
Image.Canvas.Draw(0, 0, Temp);
finally
Temp.Free;
end;
end;