FIREMONKEY - 加载替代字体

Question

我想在Delphi Firemonkey应用程序中加载外部字体。

是否有任何信息如何做到这一点？

Answer 1

不知道它是否适用于FireMonkey，但是当我想将自定义字体加载到我的标准Delphi应用程序时，此代码适用于我。

unit UExternalFonts; 

interface 

uses 
    Windows, SysUtils, Messages, Classes, Generics.Collections; 

type 
    { .: TExternalFonts :. } 
    TExternalFonts = class sealed(TList<HFONT>); 

var 
    ExternalFonts: TExternalFonts; 

function AddExternalFont(const AFileName: String): HFONT; overload; 
function AddExternalFont(const AStream: TStream): HFONT; overload; 

implementation 

{ .: DoCleanup :. } 
procedure DoCleanup(); 
var 
    I: Integer; 
begin 
    for I := ExternalFonts.Count -1 downto 0 do 
    begin 
    RemoveFontMemResourceEx(ExternalFonts[I]); 
    ExternalFonts.Delete(I); 
    //SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); 
    end; 
end; 

{ .: AddExternalFont :. } 
function AddExternalFont(const AFileName: String): HFONT; overload; 
var 
    FS: TFileStream; 
begin 
    Result := 0; 

    if not FileExists(AFileName) then 
    exit; 

    FS := TFileStream.Create(AFileName, fmOpenRead + fmShareExclusive); 
    try 
    Result := AddExternalFont(FS); 
    finally 
    FS.Free(); 
    end; 
end; 

{ .: AddExternalFont :. } 
function AddExternalFont(const AStream: TStream): HFONT; overload; 
var 
    MS: TMemoryStream; 
    Temp: DWORD; 
begin 
    Result := 0; 

    if not Assigned(AStream) then 
    exit; 

    Temp := 1; 
    MS := TMemoryStream.Create(); 
    try 
    MS.CopyFrom(AStream, 0); 

    Result := AddFontMemResourceEx(MS.Memory, MS.Size, nil, @Temp); 
    if (Result <> 0) then 
     ExternalFonts.Add(Result); 
    //SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); 
    finally 
    MS.Free(); 
    end; 
end; 

initialization 
    ExternalFonts := TExternalFonts.Create(); 

finalization 
    DoCleanup(); 
    ExternalFonts.Free(); 

end.