uses Printers; 
 
var 
  sl: TStringlist; 
 
function EnumProc(var lf: TLogFont; var tm: TNewTextMetric; 
  FontType: integer; var ts: TStrings): integer; stdcall; 
begin 
  ts.add(lf.lfFaceName + #32 + IntToStr(lf.lfHeight)); 
  result := 1; 
end; 
 
function EnumFontProc(var lf: TLogFont; var tm: TNewTextMetric; 
  FontType: integer; var ts: TStrings): integer; stdcall; 
begin 
  if FontType = TRUETYPE_FONTTYPE then begin 
    ts.add(lf.lfFaceName + ' Alle Größen'); 
  end else EnumFontFamilies(Printer.Handle, @lf.lfFaceName, 
      @EnumProc, integer(@ts)); 
  result := 1; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  if PrintDialog1.Execute then begin 
    sl := TStringlist.create; 
    sl.sorted := true; 
    sl.duplicates := dupignore; 
    EnumFontFamilies(Printer.Handle, nil, @EnumFontProc, integer(@sl)); 
    Memo1.Scrollbars := ssBoth; 
    Memo1.Lines := sl; 
    sl.free; 
  end; 
end;