问题
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.
回答1:
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;
回答2:
I've used the following solution:
Printer.ActivePrinter;
memo1.lines.AddStrings(Printer.Fonts);
declaring FMX.Printer in the uses.
回答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.
来源:https://stackoverflow.com/questions/13346620/how-to-get-the-list-of-fonts-available-delphi-xe3-firemonkey-2