Something wrong in text drawing

[WojTec]

I'm using TCanvas.TextOut() to output text on bitmap. Attached image better describe problem (please zoom it).

Simply, I want to text in pen color (green) without this terrible effect (red).

[Fusel]

Set your specific Fontname with TCanvas.Font

[WojTec]

I already did it, Arial. Do you mean problem is with font?

[Namenloser]

It has nothing to do with the font. It’s just windows’ subpixel rendering (ClearType) which smoothes out the edges of your text and makes it appear more defined. This technology was introduced with Win XP and is turned on globally by default since Vista.

You can however disable ClearType for a specific canvas.

[WojTec]

Hm, for me don't working, ClearType is as was.

[Namenloser]

It should work, though. Post some code, please.

[WojTec]

Delphi-Quellcode:

begin
  with TBitmap.Create do
  begin
    SetSize(100, 100);

    Canvas.Brush.Color := clWhite;
    Canvas.Pen.Color := clBlack;

    Canvas.FillRect(BoundsRect);

    Canvas.Font.Name := 'Arial';
    Canvas.Font.Size := 36;
    ChangeCleartype(Canvas, False);

    Canvas.TextOut(10, 10, '123'); // Without CT

    Canvas.Font.Size := 20;
    Canvas.TextOut(10, 60, '1234567');  // With CT

    SaveToFile('C:\0.bmp');
  end;
end;

I know!, need to call it before render text and after last setting! Ach.
Is possible to set it permanently for specified font?

[himitsu]

Ja.

Leite dir TFont ab und baue diese Funktionalität dort ein.

[WojTec]

I don't understand too much, you mean I should write new class with this function inside? I alread made helper class, but need to set property before render text.

I see Delphi disallow add fields in helpers, very bad

If I create extended font class TFontEx = class(TFont), how to use it in canvas?

[DeddyH]

I tried a little bit and this seems to work (only a form with a button on it):

Delphi-Quellcode:

unit Unit6;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TFont = class(Graphics.TFont)
  private
    procedure SetClearType(Value: Boolean);
    function GetClearType: Boolean;
  public
    property ClearType: Boolean read GetClearType write SetClearType;
  end;

  TfrmFontTest = class(TForm)
    Button1: TButton;
    procedure FormPaint(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private-Deklarationen }
    FClearType: Boolean;
    procedure ToggleClearType;
  public
    { Public-Deklarationen }
  end;

var
  frmFontTest: TfrmFontTest;

implementation

{$R *.dfm}
{ TFont }

function TFont.GetClearType: Boolean;
var
  lf: TLogFont;
begin
  GetObject(Handle, sizeof(lf), @lf);
  Result := lf.lfQuality = DEFAULT_QUALITY;
end;

procedure TFont.SetClearType(Value: Boolean);
var
  lf: TLogFont;
begin
  GetObject(Handle, sizeof(lf), @lf);
  if Value then
    lf.lfQuality := DEFAULT_QUALITY
  else
    lf.lfQuality := NONANTIALIASED_QUALITY;
  Handle := CreateFontIndirect(lf);
end;

procedure TfrmFontTest.Button1Click(Sender: TObject);
begin
  ToggleClearType;
end;

procedure TfrmFontTest.ToggleClearType;
var
  ft: TFont;
begin
  FClearType := not FClearType;
  ft := TFont.Create;
  try
    ft.Assign(Canvas.Font);
    ft.ClearType := FClearType;
    Canvas.Font.Assign(ft);
    Invalidate;
  finally
    ft.Free;
  end;
end;

procedure TfrmFontTest.FormCreate(Sender: TObject);
begin
  FClearType := true;
end;

procedure TfrmFontTest.FormPaint(Sender: TObject);
begin
  Canvas.TextOut(10, 10, 'And now for something completely different...');
end;

end.