如何获得可用字体的列表-Delphi XE3 + Firemonkey 2?

问题描述

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

In order to create a font picker I need to get the list of fonts available to Firemonkey.As Screen.Fonts doesn't exist in FireMonkey I thought I'd need to use FMX.Platform ?eg:

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

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

However, the only function available is to return the default Font name.

目前，我对跨平台支持并不感到烦恼，但是如果我打算转到Firemonkey，我宁愿尽可能不要依赖Windows调用.

At the moment I'm not bothered about cross-platform support but if I'm going to move to Firemonkey I'd rather not rely on Windows calls where possible.

推荐答案

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

The cross platform solution should use the MacApi.AppKit and Windows.Winapi together in conditional defines.

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

First Add these code to your uses clause:

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

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

Then add this code to your implementation:

{$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过程.不要忘记将非nil TStringlist传递给该过程.典型用法如下:

Now you can use CollectFonts procedure. Don't forget to pass a non-nil TStringlist to the procedure.A typical usage may be like this.

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;

这篇关于如何获得可用字体的列表-Delphi XE3 + Firemonkey 2?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！