枚举当前字体

function EnumFontFamilyProc(var lf : TLogFont;
                            var tm : TNewTextMetric;
                            FontType : integer;
                            var Memo : TMemo) : integer
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
begin
  Memo.Lines.Add(StrPas(@lf.lfFaceName) +
                        #32 + IntToStr(lf.lfHeight));
  result := 1;
end;

function EnumFontFamiliesProc(var lf : TLogFont;
                              var tm : TNewTextMetric;
                              FontType : integer;
                              var Memo : TMemo) : integer
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
begin
  if FontType = TRUETYPE_FONTTYPE then begin
    Memo.Lines.Add(StrPas(@lf.lfFaceName) + #32 + ‘All Sizes‘);
  end else
    EnumFontFamilies(Printer.Handle,
                     @lf.lfFaceName,
                     @EnumFontFamilyProc,
                     LongInt(@Memo));
  result := 1;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  tm : TTextMetric;
  i : integer;
begin
  if PrintDialog1.Execute then begin
    EnumFontFamilies(Printer.Handle,
                     nil,
                     @EnumFontFamiliesProc,
                     LongInt(@Memo1));
  end;
end;

枚举当前字体

原文：http://www.cnblogs.com/yzryc/p/6374302.html