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.
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;