Come ottenere l'elenco dei tipi di carattere disponibili - Delphi XE3 + Firemonkey 2?

Question

Per creare un selettore di caratteri ho bisogno di ottenere l'elenco di caratteri disponibili per Firemonkey. Siccome Screen.Fonts non esiste in FireMonkey ho pensato che avrei dovuto usare FMX.Platform? esempio:

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

Tuttavia, l'unica funzione disponibile è quello di restituire il nome predefinito di carattere.

Al momento non sono preoccupato per il supporto multipiattaforma, ma se ho intenzione di passare a Firemonkey preferisco non fare affidamento su chiamate di Windows, ove possibile.

Answer 1

La soluzione multipiattaforma deve utilizzare MacApi.AppKit e Windows.Winapi insieme in definizioni condizionali.

First Aggiungi questi codice al tuo clausola uses:

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

Quindi aggiungere il codice per l'implementazione:

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

Ora è possibile utilizzare procedura CollectFonts. Non dimenticare di passare una TStringlist non nulla alla procedura. Un utilizzo tipico potrebbe essere come questo.

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

Ho usato la seguente soluzione:

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

dichiarando FMX.Printer negli usi.

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.