Test fontu – Delphi – Fórum – Programujte.com

Používám Delphi 7  

unit Testfnt;

//  Uc_heb - Hebrak 2.31

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, StdCtrls;
type
 tbarva = array[1..7,1..2] of integer;
  TFtestfont = class(TForm)
    Panel1: TPanel;
    Pfonttest: TPaintBox;
    Label1: TLabel;
    Label2: TLabel;
    Button1: TButton;
    Timer1: TTimer; // obsluhován Timer1Timer
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
    bila : tbarva;
    cerna : tbarva;
    testovanyfont: string;
    testch: char;
    function testujfont: boolean;

  public
    { Public declarations }
    function testujhebrew : boolean;
    function testujgreek : boolean;
  end;

var
  Ftestfont: TFtestfont;

implementation

{$R *.DFM}
function TFtestfont.testujfont: boolean;
var i : integer;
begin
 with pfonttest.canvas do
  begin
   with font do
    begin
     color  := clblack;
     name   := testovanyfont;
     pitch  := fpDefault;
     height := -80;
     style  := [];
    end;
  brush.color := clwhite;
  textout(0,0,testch);
  result := true;
  for i:=1 to 7 do
   begin
    if pixels[bila[i,1],bila[i,2]]<>16777215
          then result := false;
    if pixels[cerna[i,1],cerna[i,2]]<>0
          then result := false;
   end;
  end;
 end;

function TFtestfont.testujhebrew : boolean;
const bil:tbarva=((8,36),(20,36),(16,48),(9,47),(31,51),
        (10,26),(22,26));
      cer:tbarva=((3,26),(15,26),(30,29),(30,16),(6,50),
        (9,58),(26,53));
begin
  testovanyfont := 'Hebrew';
  testch        := 'v';
  bila          := bil;
  cerna         := cer;
  result        := testujfont;
end;

function TFtestfont.testujgreek : boolean;
const bil:tbarva=((2,34),(12,66),(18,65),(19,59),(12,60),
        (39,34),(40,27));
      cer:tbarva=((5,31),(25,15),(41,30),(16,63),(3,57),
        (27,59),(11,77));
begin
  testovanyfont := 'BwGrki';
  testch        :='y';
  bila          := bil;
  cerna         := cer;
  result        :=testujfont;
end;


procedure TFtestfont.Button1Click(Sender: TObject);
begin
  close;
end;

procedure TFtestfont.FormActivate(Sender: TObject);
var hbr,grk: boolean;
    kyd:string;
begin
kyd:=' Fonty '+
   'přibalené k programu je nutno nainstalovat '+
   'standardním postupem Windows. (Přečtěte si nápovědu uc_heb.htm, část instalace!)';
if testujhebrew then hbr:=true else hbr:=false;
if testujgreek then grk:=true else grk:=false;

if hbr and grk then
   begin
    label4.visible:=true;
    label2.visible:=false;
    timer1.enabled:=true;
    exit;
   end;
label1.visible := false;
label3.visible := false;
if (not hbr) and grk then
   begin
    label2.caption:=
        'Font Hebrew není v pořádku. Buď není nainstalován vůbec '
         +'nebo je nainstalována jeho jiná verze. Testy se nemusí '
         +'zobrazovat správně.'{+kyd+'Hebrew-OK).'};
    button1.visible:=true;
    label5.visible:=true;
    LABEL5.caption:=kyd{+'Hebrew - OK).'};
   end;
if  hbr and (not grk) then
   begin
    label2.caption:=
        'Font BwGrki není v pořádku. Buď není nainstalován vůbec '
         +'nebo je nainstalována jeho jiná verze. Testy se nemusí '
         +'zobrazovat správně.'{+kyd+ 'Bwgrki-OK).'};
    button1.visible:=true;
    label5.visible:=true;
    LABEL5.caption:=kyd+ 'Bwgrki - OK).';
   end;
if (not hbr) and  (not grk) then
   begin
    label2.caption:=
        'Fonty Hebrew a BwGrki nejsou v pořádku. Buď nejsou nainstalovány vůbec '
         +'nebo je nainstalována jejich jiná verze. Testy se nemusí '
         +'zobrazovat správně.'{+kyd+'Hebrew a Bwgrki-OK).'};
    button1.visible:=true;
    label5.visible:=true;
    LABEL5.caption:=kyd+ 'Hebrew a Bwgrki - OK).';
   end;
end;

procedure TFtestfont.Timer1Timer(Sender: TObject);
begin
  timer1.enabled:=false;
  close;
end;

end.

Tento kod má za úkol zjistit jestli jsou nainstalovány fonty BWGRKI.TTF a HEBREW.TTF.

Chci se zeptat, jak by se dal tento modul upravit

1) abych si mohl prohlédnout ve formuláři jak vypadá to co bylo nakteslené do TPaintBox?

2) Jak to upravit, aby se to co se vykreslilo uložilo do souboru? Přesněji: rád bych vytiskl jedno písmeno o velikosti např. 12px do obrázku např. greek.png

3) Provést načtení z tohoto obrázku (místo toho abych psal data ručně bych je chtěl načíst a porovnat automaticky.

Jde mi o to, že mám více fontů, asi tak 10 a jejich testování se mi nechce dělat takto ručně jak je to v kódu nastavováním nějakých pixelů:

const bil:tbarva=((2,34),(12,66),(18,65),(19,59),(12,60),
        (39,34),(40,27));
      cer:tbarva=((5,31),(25,15),(41,30),(16,63),(3,57),
        (27,59),(11,77));

#1 oxidián
Já teď zjistil že seznam fontů je v Screen.Fonts takže ten kód nepotřebuju.