7

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.

RBA
  • 12,337
  • 16
  • 79
  • 126
sergeantKK
  • 644
  • 7
  • 16

3 Answers3

9

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;
Andrew Barber
  • 39,603
  • 20
  • 94
  • 123
mehmed.ali
  • 252
  • 1
  • 4
  • Thank you very much! I'll accept as correct when I get chance to test it out, but it looks like a great answer to me :) – sergeantKK Nov 20 '12 at 13:51
  • Hello, you can check my blog to see a full working solution: http://delphiscience.wordpress.com/2012/11/20/getting-system-fonts-list-in-firemonkey-the-new-tplatformextensions-class/ – mehmed.ali Nov 20 '12 at 14:26
  • @mehmed.ali By the way; there's a place in your profile here where you can (and should) add a link to your blog's home page. – Andrew Barber Nov 20 '12 at 16:15
  • @mehmed.ali: Thank you again, your blog looks very useful, just bogged down with other stuff at the moment to check it fully. I think it's fine to have a link to the blog in the comments or maybe a note to "check the blog in my profile for a working example" would be better? – sergeantKK Nov 20 '12 at 16:43
  • @Andrew: Thanks Andrew. I didn't know it. I will do it right know. – mehmed.ali Nov 20 '12 at 19:15
  • @sergeantKK: Thanks for your kind words. I will do my best to make the blog updated with the Firemonkey cases. – mehmed.ali Nov 20 '12 at 19:16
5

I've used the following solution:

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

declaring FMX.Printer in the uses.

Torsen
  • 151
  • 1
  • 7
  • Hello, have you tested it on MAcSide. RefreshFonts method of TPrinter is not implemented on MacSide, so I think if you use it your code will not be cross-platform. – mehmed.ali Jan 10 '13 at 09:39
-2

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.

kepa
  • 1