AGB  ·  Datenschutz  ·  Impressum  







Anmelden
Nützliche Links
Registrieren
Thema durchsuchen
Ansicht
Themen-Optionen

Something wrong in text drawing

Ein Thema von WojTec · begonnen am 20. Aug 2011 · letzter Beitrag vom 21. Aug 2011
 
Benutzerbild von DeddyH
DeddyH

Registriert seit: 17. Sep 2006
Ort: Barchfeld
27.656 Beiträge
 
Delphi 12 Athens
 
#10

AW: Something wrong in text drawing

  Alt 21. Aug 2011, 12:35
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.
Detlef
"Ich habe Angst vor dem Tag, an dem die Technologie unsere menschlichen Interaktionen übertrumpft. Die Welt wird eine Generation von Idioten bekommen." (Albert Einstein)
Dieser Tag ist längst gekommen
  Mit Zitat antworten Zitat
 


Forumregeln

Es ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.

BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus.
Trackbacks are an
Pingbacks are an
Refbacks are aus

Gehe zu:

Impressum · AGB · Datenschutz · Nach oben
Alle Zeitangaben in WEZ +1. Es ist jetzt 12:19 Uhr.
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024-2025 by Thomas Breitkreuz