如何獲取可用字體列表 - Delphi XE3 + Firemonkey 2？

爲了創建一個字體選擇器，我需要獲取Firemonkey可用的字體列表。由於Screen.Fonts在FireMonkey中不存在我以爲我需要使用FMX.Platform？如：如何獲取可用字體列表 - Delphi XE3 + Firemonkey 2？

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

然而，唯一可用的功能是返回默認字體名稱。

目前我並不擔心跨平臺支持，但如果我要轉移到Firemonkey，我寧願不要依賴Windows電話。

來源

2012-11-12 sergeantKK

跨平臺解決方案應該在條件定義中一起使用MacApi.AppKit和Windows.Winapi。

首先這些代碼添加到您的使用條款：

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

然後將此代碼添加到您的實現：

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

現在你可以使用CollectFonts過程。不要忘記將非零TStringlist傳遞給過程。典型的用法可能是這樣的。

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;

來源

2012-11-19 21:51:21

非常感謝！當我有機會進行測試時，我會接受正確的答案，但對我來說這看起來是一個很好的答案:) – sergeantKK

您好，您可以查看我的博客以查看完整的工作解決方案：http://delphiscience.wordpress.com/2012/11/20/getting-system-fonts-list-in-firemonkey-the-new-tplatformextensions-class/ –

@ mehmed.ali順便提一下;在你的個人資料中有一個地方，你可以（也應該）在你的博客主頁上添加一個鏈接。 –

我用以下解決方案：

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

的用途聲明FMX.Printer。

來源

2012-11-25 20:39:02 Torsen

謝謝 - 這似乎也起作用！ – sergeantKK

你好，你有沒有在MAcSide上測試過它。 TPrint的RefreshFonts方法沒有在MacSide上實現，所以我認爲如果你使用它，你的代碼將不會是跨平臺的。 –

 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.

來源

2015-06-30 12:53:17 kepa

如何獲取可用字體列表 - Delphi XE3 + Firemonkey 2？

回答

相關問題