procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  FSelfFont:= TFont.Create;
  FSelfFont.Assign(Screen.SystemFont);

  with lbxSize do
  begin
    Clear;
    for i:= 8 to 20 do
      if ((i mod (i div 2)) = 0) then
        Items.Add(IntToStr(i));
    ItemIndex:= 6;
  end;

  FillLB(lbxText);
  lbxSizeClick(Self);
end;

procedure TForm1.btnApplyFontClick(Sender: TObject);
begin
  FontDialog1.Font.Assign(FSelfFont);
  if FontDialog1.Execute then
  begin
    FSelfFont.Assign(FontDialog1.Font);
    lbxSize.ItemIndex:= lbxSize.Items.IndexOf(IntToStr(FontDialog1.Font.Size));
    lbxText.Repaint;
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
  FSelfFont.Free;
end;

procedure TForm1.lbxTextMeasureItem(Control: TWinControl; Index: Integer;
  var AHeight: Integer);
begin
  lbxText.Canvas.Font.Assign(FSelfFont);
  AHeight:= lbxText.Canvas.TextHeight(lbxText.Items[Index]);
  lbxText.Repaint;
end;

procedure TForm1.lbxTextDrawItem(Control: TWinControl; Index: Integer;
  ARect: TRect; State: TOwnerDrawState);
begin
  with lbxText do
  begin
    Canvas.Font.Assign(FSelfFont);
    Canvas.FillRect(ARect);
    Canvas.TextOut(ARect.Left,ARect.Top,Items[Index]);
  end;
end;

procedure TForm1.lbxSizeClick(Sender: TObject);
begin
  FSelfFont.Size:= StrToInt(lbxSize.Items[lbxSize.ItemIndex]);
  lbxText.Invalidate;
end;

procedure TForm1.FillLB(Sender: TListBox);
begin
  with TListBox(Sender) do
  begin
    Clear;
    Style:= lbOwnerDrawVariable;
    Items.Add('abcdefghijklmnopqrstuvwxyz');
    Items.Add('ABCDEFGHIJKLMNOPQRSTUVWXYZ');
    Items.Add('01234567891   ўЈ¤Ґ§');
    Items.Add('абвгдежзийклмнопрстуфхцшщъыь');
    Items.add('АБВГДЕЖЗИЙКЛМНОПРСТУФХХШЩЪЫЬЭЯ');
  end;
end;

end.