如何获取可用字体列表 - Delphi XE3 + Firemonkey 2？答案

【问题标题】：How to get the list of fonts available - Delphi XE3 + Firemonkey 2?如何获取可用字体列表 - Delphi XE3 + Firemonkey 2？
【发布时间】：2012-11-12 15:34:26
【问题描述】：

为了创建字体选择器，我需要获取 Firemonkey 可用的字体列表。由于 FireMonkey 中不存在 Screen.Fonts 我认为我需要使用 FMX.Platform 吗？例如：

if TPlatformServices.Current.SupportsPlatformService(IFMXSystemFontService, IInterface(FontSvc)) then
  begin
    edit1.Text:= FontSvc.GetDefaultFontFamilyName;
  end
  else
    edit1.Text:= DefaultFontFamily;

但是，唯一可用的功能是返回默认字体名称。

目前我不关心跨平台支持，但如果我要迁移到 Firemonkey，我宁愿尽可能不依赖 Windows 调用。

【问题讨论】：

标签： delphi firemonkey delphi-xe3 firemonkey-fm2

【解决方案1】：

跨平台解决方案应在条件定义中同时使用 MacApi.AppKit 和 Windows.Winapi。

首先将这些代码添加到您的 uses 子句中：

{$IFDEF MACOS}
MacApi.Appkit,Macapi.CoreFoundation, Macapi.Foundation,
{$ENDIF}
{$IFDEF MSWINDOWS}
Winapi.Messages, Winapi.Windows,
{$ENDIF}

然后将此代码添加到您的实现中：

{$IFDEF MSWINDOWS}
function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  FontType: Integer; Data: Pointer): Integer; stdcall;
var
  S: TStrings;
  Temp: string;
begin
  S := TStrings(Data);
  Temp := LogFont.lfFaceName;
  if (S.Count = 0) or (AnsiCompareText(S[S.Count-1], Temp) <> 0) then
    S.Add(Temp);
  Result := 1;
end;
{$ENDIF}

procedure CollectFonts(FontList: TStringList);
var
{$IFDEF MACOS}
  fManager: NsFontManager;
  list:NSArray;
  lItem:NSString;
{$ENDIF}
{$IFDEF MSWINDOWS}
  DC: HDC;
  LFont: TLogFont;
{$ENDIF}
  i: Integer;
begin

  {$IFDEF MACOS}
    fManager := TNsFontManager.Wrap(TNsFontManager.OCClass.sharedFontManager);
    list := fManager.availableFontFamilies;
    if (List <> nil) and (List.count > 0) then
    begin
      for i := 0 to List.Count-1 do
      begin
        lItem := TNSString.Wrap(List.objectAtIndex(i));
        FontList.Add(String(lItem.UTF8String))
      end;
    end;
  {$ENDIF}
  {$IFDEF MSWINDOWS}
    DC := GetDC(0);
    FillChar(LFont, sizeof(LFont), 0);
    LFont.lfCharset := DEFAULT_CHARSET;
    EnumFontFamiliesEx(DC, LFont, @EnumFontsProc, Winapi.Windows.LPARAM(FontList), 0);
    ReleaseDC(0, DC);
  {$ENDIF}
end;

现在您可以使用 CollectFonts 程序了。不要忘记给过程传递一个非零的TStringlist。一个典型的用法可能是这样的。

procedure TForm1.FormCreate(Sender: TObject);
var fList: TStringList;
    i: Integer;
begin
  fList := TStringList.Create;
  CollectFonts(fList);
  for i := 0 to fList.Count -1 do
  begin
     ListBox1.Items.Add(FList[i]);
  end;
  fList.Free;
end;

【讨论】：

非常感谢！当我有机会测试它时，我会接受它是正确的，但这对我来说似乎是一个很好的答案:)
您好，您可以查看我的博客以查看完整的工作解决方案：delphiscience.wordpress.com/2012/11/20/…
@mehmed.ali 顺便说一句；在您的个人资料中有一个位置，您可以（并且应该）在其中添加指向您博客主页的链接。
@mehmed.ali: 再次感谢您，您的博客看起来很有用，目前正忙于其他内容以全面检查它。我认为在 cmets 中有一个指向博客的链接很好，或者在我的个人资料中添加一个注释以“检查我的个人资料中的博客以获取工作示例”会更好？
@Andrew：谢谢安德鲁。我不知道。我会做好的。

【解决方案2】：

我使用了以下解决方案：

  Printer.ActivePrinter;
  memo1.lines.AddStrings(Printer.Fonts);

在使用中声明 FMX.Printer。

【讨论】：

你好，你在MACSide上测试过吗？ MacSide 没有实现 TPrinter 的 RefreshFonts 方法，所以我认为如果你使用它，你的代码将不会是跨平台的。

【解决方案3】：

unit Unit1;

interface

uses
  Windows, SysUtils, Classes, Forms, Controls, StdCtrls;

type
  TForm1 = class(TForm)
    ComboBox1: TComboBox;
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}                      

procedure TForm1.FormShow(Sender: TObject);
begin
  ComboBox1.Items.Assign(Screen.Fonts);
  ComboBox1.Text := 'Fonts...';
end;

end.

【讨论】：

这是一个 VCL 答案，而不是 FMX 答案。