Z AntiAliasing, ale nie powiem... nie wygląda schludnie...
uses Math;
procedure AntiAliasRect(Bmp: TBitmap; Rect: TRect);
var
x, y: Integer;
p0, p1, p2: pByteArray;
begin
Rect.Left := Max(1, Rect.Left);
Rect.Top := Max(1, Rect.Top);
Rect.Right := Min(Bmp.Width-2, Rect.Right);
Rect.Bottom := Min(Bmp.Height-2, Rect.Bottom);
Bmp.PixelFormat := pf24bit;
for y := Rect.Top to Rect.Bottom do
begin
p0 := Bmp.ScanLine[y-1];
p1 := Bmp.scanline[y];
p2 := Bmp.ScanLine[y+1];
for x := Rect.Left to Rect.Right do
begin
p1[x*3] := (p0[x*3] + p2[x*3] + p1[(x-1)*3] + p1[(x+1)*3]) shr 2;
p1[x*3+1] := (p0[x*3+1] + p2[x*3+1] + p1[(x-1)*3+1] + p1[(x+1)*3+1]) shr 2;
p1[x*3+2] := (p0[x*3+2] + p2[x*3+2] + p1[(x-1)*3+2] + p1[(x+1)*3+2]) shr 2;
end;
end;
end;
procedure TForm6.Button1Click(Sender: TObject);
const
TestText = '4programmers.net';
var
Can: TCanvas;
R: TRect;
Bmp: TBitmap;
begin
Can := Image1.Canvas;
with Can do
begin
Font.Size := 36;
Font.Color := clRed;
Font.Style := Font.Style + [fsBold];
Font.Name := 'Arial'; //wymaga TrueType!
Brush.Color := clBlack;
Brush.Style := bsSolid;
Pen.Color := clWhite;
Pen.Style := psSolid;
Pen.Width := 2;
FillRect(TPaintBox(Sender).ClientRect);
{Uncomment the following line to see the text output rect in black}
Brush.Color := clBlack;
{This draws the interior of the letters}
TextOut(0, 0, TestText);
end;
{Uncomment the following block to remove the frame drawn around the text by StrokePath }
R.TopLeft := Point(0, 0);
R.BottomRight := TPoint(Can.TextExtent(TestText));
InflateRect(R, -1, -1);
IntersectClipRect(Can.Handle, R.Left, R.Top, R.Right, R.Bottom);
{This draws an outline around the letters}
with Can do
begin
BeginPath(Handle);
Pen.Width := 3;
TextOut(0, 0, TestText);
EndPath(Handle);
StrokePath(Handle);
end;
Bmp := Image1.Picture.Bitmap;
AntiAliasRect(Bmp, Rect(0, 0, Bmp.Width, Bmp.Height));
end;