Jak uzyskać listę dostępnych czcionek - Delphi XE3 + Firemonkey 2?

Question

Aby utworzyć próbnik czcionek, muszę uzyskać listę dostępnych czcionek dla Firemonkey. Jako że Screen.Fonts nie istnieje w FireMonkey Myślałem, że będę musiał użyć FMX.Platform? np

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

Jednak tylko funkcja dostępna jest przywrócenie domyślnej nazwy czcionki.

W tej chwili nie przejmuję się obsługą wielu platform, ale jeśli mam zamiar przenieść się do Firemonkey, raczej nie polegam na wywołaniach systemu Windows, jeśli to możliwe.

Answer 1

Rozwiązanie dla platformy wieloplatformowej powinno wykorzystywać MacApi.AppKit i Windows.Winapi łącznie w definicjach warunkowych.

najpierw dodać te kod do klauzuli zastosowań:

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

Następnie dodać ten kod do swojej realizacji:

{$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; 

Teraz można korzystać z procedury CollectFonts. Nie zapomnij o przekazaniu niezarejestrowanej listy TStringlist do procedury. Typowe użycie może być podobne.

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; 

Answer 2

Użyłem następujące rozwiązanie:

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

uznającą FMX.Printer w zastosowaniach.

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