How to anti-alias text (Views: 52)
Problem/Question/Abstract: 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: procedure SetTextAngle(Canvas: TCanvas; Angle: Integer); var LogFont: TLogFont; begin GetObject(Canvas.Font.Handle, SizeOf(LogFont), Addr(LogFont)); with LogFont do begin lfEscapement := Angle; lfOrientation := Angle; lfQuality := ANTIALIASED_QUALITY; lfOutPrecision := OUT_TT_ONLY_PRECIS; end; Canvas.Font.Handle := CreateFontIndirect(LogFont); end; Solve 2: Here is another way of doing this: procedure TForm1.Button1Click(Sender: TObject); var LogFont: TLogFont; begin Font.Name := 'Arial'; { make sure it is a true type font } Font.Size := 48; { sometimes small fonts are not antialiased } GetObject(Font.Handle, SizeOf(LogFont), @LogFont); LogFont.lfQuality := ANTIALIASED_QUALITY; Canvas.Font.Handle := CreateFontIndirect(LogFont); Repaint; { just to make sure our text is not erased immediately } Canvas.TextOut(50, 50, 'Antialiased Text'); end; Solve 3: procedure DrawAAText(Dest: TBitmap; DX, DY: Integer; Text: string); type pRGBLine = ^TRGBLine; TRGBLine = array[Word] of TRGBTriple; {Separate R, G and B values from the color} procedure SeparateColor(Color: TColor; var r: Byte; var g: byte; var b: byte); begin R := Color and $FF0000 shr 16; G := Color and $00FF00 shr 8; B := Color and $0000FF; end; var TempBitmap: TBitmap; x, y: Integer; totr, totg, totb: Integer; j, i: Integer; Line: pRGBLine; TempLine: array[0..1] of pRGBLine; begin {Creates a temporary bitmap do work with supersampling} TempBitmap := TBitmap.Create; with TempBitmap do begin PixelFormat := pf24bit; {Copy attributes from previous bitmap} Canvas.Font.Assign(Dest.Canvas.Font); Canvas.Brush.Assign(Dest.Canvas.Brush); Canvas.Pen.Assign(Dest.Canvas.Pen); Canvas.Font.Size := Canvas.Font.Size * 2; {Make it twice larger to apply supersampling later} Width := Canvas.TextWidth(Text); Height := Canvas.TextHeight(Text); {To prevent unexpected junk} if (Width div 2) + DX > Dest.Width then Width := (Dest.Width - DX) * 2; if (Height div 2) + DY > Dest.Height then Height := (Dest.Height - DY) * 2; {If the brush style is clear, then copy the image from the previous image to create the propher effect} if Canvas.Brush.Style = bsClear then begin Canvas.Draw(-DX, -DY, Dest); Canvas.Stretchdraw(Rect(0, 0, Width * 2, Height * 2), TempBitmap); end; {Draws the text using double size} Canvas.TextOut(0, 0, Text); end; {Draws the antialiased image} for y := 0 to ((TempBitmap.Height) div 2) - 1 do begin {If the y pixel is outside the clipping region, do the proper action} if dy + y < 0 then Continue else if Dy + y > Dest.Height - 1 then Break; {Scanline for faster access} Line := Dest.ScanLine[DY + y]; TempLine[0] := TempBitmap.Scanline[2 * y]; TempLine[1] := TempBitmap.Scanline[(2 * y) + 1]; for x := 0 to ((TempBitmap.Width) div 2) - 1 do begin {If the x pixel is outside the clipping region, do the proper action} if dx + x < 0 then Continue else if Dx + x > Dest.Width - 1 then Break; {Compute the value of the output pixel (x, y) } TotR := 0; TotG := 0; TotB := 0; for j := 0 to 1 do begin for i := 0 to 1 do with TempLine[j][2 * x + i] do begin inc(TotR, rgbtRed); inc(TotG, rgbtGreen); inc(TotB, rgbtBlue); end; end; {Set the pixel values thru scanline} with Line[DX + x] do begin rgbtRed := TotR div 4; rgbtGreen := TotG div 4; rgbtBlue := TotB div 4; end; end; end; {Free the temporary bitmap} TempBitmap.Free; end; |