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.

FIREMONKEY - 加载替代字体

1 个答案: