Code:

unit Fontlist;

 

interface

 

uses

Windows, Classes, Graphics, Forms, Controls, StdCtrls;

 

type

TForm1 = class(TForm)

   ListBox1: TListBox;

   Label1: TLabel;

   FontLabel: TLabel;

   procedure FormCreate(Sender: TObject);

   procedure ListBox1Click(Sender: TObject);

   procedure DrawItem(Control: TWinControl; index: Integer; Rect: TRect;

     State: TOwnerDrawState);

   procedure ListBox1MeasureItem(Control: TWinControl; index: Integer;

     var Height: Integer);

private

   { Private declarations }

public

   { Public declarations }

end;

 

var

Form1: TForm1;

 

implementation

 

{$R *.DFM}

 

procedure TForm1.FormCreate(Sender: TObject);

begin

Listbox1.Items := Screen.Fonts;

end;

 

procedure TForm1.ListBox1Click(Sender: TObject);

begin

FontLabel.Caption := ListBox1.Items[ListBox1.ItemIndex];

end;

 

procedure TForm1.DrawItem(Control: TWinControl; index: Integer;

Rect: TRect; State: TOwnerDrawState);

begin

with ListBox1.Canvas do

begin

   FillRect(Rect);

   Font.name := ListBox1.Items[index];

   Font.Size := 0; // use font's preferred size

   TextOut(Rect.Left+1, Rect.Top+1, ListBox1.Items[index]);

end;

end;

 

procedure TForm1.ListBox1MeasureItem(Control: TWinControl; index: Integer;

var Height: Integer);

begin

with ListBox1.Canvas do

begin

   Font.name := Listbox1.Items[index];

   Font.Size := 0; // use font's preferred size

   Height := TextHeight('Wg') + 2; // measure ascenders and descenders

end;

end;

 

end.

 

Добавить комментарий

Не использовать не нормативную лексику.

Просьба писать ваши замечания, наблюдения и все остальное,
что поможет улучшить предоставляемую информацию на этом сайте.

ВСЕ КОММЕНТАРИИ МОДЕРИРУЮТСЯ ВРУЧНУЮ, ТАК ЧТО СПАМИТЬ БЕСПОЛЕЗНО!


Защитный код
Обновить