Something wrong in text drawing

[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.