Author: Jonas Bilinkevicius
Are there any anti-alias effect in the TEXT GDI functions? For example, when I do a
TextOut or DrawText, how can I make the text anti-alias?
Answer:
Solve 1:
Yes. The quality is a property of the font. You need to setup the font. Some time
ago I was implementing a function to rotate text and you can use the same routine:
1
2 procedure SetTextAngle(Canvas: TCanvas; Angle: Integer);
3 var
4 LogFont: TLogFont;
5 begin
6 GetObject(Canvas.Font.Handle, SizeOf(LogFont), Addr(LogFont));
7 with LogFont do
8 begin
9 lfEscapement := Angle;
10 lfOrientation := Angle;
11 lfQuality := ANTIALIASED_QUALITY;
12 lfOutPrecision := OUT_TT_ONLY_PRECIS;
13 end;
14 Canvas.Font.Handle := CreateFontIndirect(LogFont);
15 end;
Solve 2:
Here is another way of doing this:
16 procedure TForm1.Button1Click(Sender: TObject);
17 var
18 LogFont: TLogFont;
19 begin
20 Font.Name := 'Arial'; { make sure it is a true type font }
21 Font.Size := 48; { sometimes small fonts are not antialiased }
22 GetObject(Font.Handle, SizeOf(LogFont), @LogFont);
23 LogFont.lfQuality := ANTIALIASED_QUALITY;
24 Canvas.Font.Handle := CreateFontIndirect(LogFont);
25 Repaint; { just to make sure our text is not erased immediately }
26 Canvas.TextOut(50, 50, 'Antialiased Text');
27 end;
Solve 3:
28
29 procedure DrawAAText(Dest: TBitmap; DX, DY: Integer; Text: string);
30 type
31 pRGBLine = ^TRGBLine;
32 TRGBLine = array[Word] of TRGBTriple;
33
34 {Separate R, G and B values from the color}
35 procedure SeparateColor(Color: TColor; var r: Byte; var g: byte; var b: byte);
36 begin
37 R := Color and $FF0000 shr 16;
38 G := Color and $00FF00 shr 8;
39 B := Color and $0000FF;
40 end;
41
42 var
43 TempBitmap: TBitmap;
44 x, y: Integer;
45 totr, totg, totb: Integer;
46 j, i: Integer;
47 Line: pRGBLine;
48 TempLine: array[0..1] of pRGBLine;
49 begin
50 {Creates a temporary bitmap do work with supersampling}
51 TempBitmap := TBitmap.Create;
52 with TempBitmap do
53 begin
54 PixelFormat := pf24bit;
55 {Copy attributes from previous bitmap}
56 Canvas.Font.Assign(Dest.Canvas.Font);
57 Canvas.Brush.Assign(Dest.Canvas.Brush);
58 Canvas.Pen.Assign(Dest.Canvas.Pen);
59 Canvas.Font.Size := Canvas.Font.Size * 2;
60 {Make it twice larger to apply supersampling later}
61 Width := Canvas.TextWidth(Text);
62 Height := Canvas.TextHeight(Text);
63 {To prevent unexpected junk}
64 if (Width div 2) + DX > Dest.Width then
65 Width := (Dest.Width - DX) * 2;
66 if (Height div 2) + DY > Dest.Height then
67 Height := (Dest.Height - DY) * 2;
68 {If the brush style is clear, then copy the image from the previous
69 image to create the propher effect}
70 if Canvas.Brush.Style = bsClear then
71 begin
72 Canvas.Draw(-DX, -DY, Dest);
73 Canvas.Stretchdraw(Rect(0, 0, Width * 2, Height * 2), TempBitmap);
74 end;
75 {Draws the text using double size}
76 Canvas.TextOut(0, 0, Text);
77 end;
78 {Draws the antialiased image}
79 for y := 0 to ((TempBitmap.Height) div 2) - 1 do
80 begin
81 {If the y pixel is outside the clipping region, do the proper action}
82 if dy + y < 0 then
83 Continue
84 else if Dy + y > Dest.Height - 1 then
85 Break;
86 {Scanline for faster access}
87 Line := Dest.ScanLine[DY + y];
88 TempLine[0] := TempBitmap.Scanline[2 * y];
89 TempLine[1] := TempBitmap.Scanline[(2 * y) + 1];
90 for x := 0 to ((TempBitmap.Width) div 2) - 1 do
91 begin
92 {If the x pixel is outside the clipping region, do the proper action}
93 if dx + x < 0 then
94 Continue
95 else if Dx + x > Dest.Width - 1 then
96 Break;
97 {Compute the value of the output pixel (x, y) }
98 TotR := 0;
99 TotG := 0;
100 TotB := 0;
101 for j := 0 to 1 do
102 begin
103 for i := 0 to 1 do
104 with TempLine[j][2 * x + i] do
105 begin
106 inc(TotR, rgbtRed);
107 inc(TotG, rgbtGreen);
108 inc(TotB, rgbtBlue);
109 end;
110 end;
111 {Set the pixel values thru scanline}
112 with Line[DX + x] do
113 begin
114 rgbtRed := TotR div 4;
115 rgbtGreen := TotG div 4;
116 rgbtBlue := TotB div 4;
117 end;
118 end;
119 end;
120 {Free the temporary bitmap}
121 TempBitmap.Free;
122 end;
|
