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