delphifiremonkeydelphi-xe3firemonkey-fm2

How to get the list of fonts available - Delphi XE3 + Firemonkey 2?


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.

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.


Solution

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

    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;
    

    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;