FIREMONKEY - загрузить альтернативный шрифт - PullRequest
Новая
       29

FIREMONKEY - загрузить альтернативный шрифт

2 голосов
/ 29 февраля 2012

Я бы хотел загрузить внешний шрифт в приложение Delphi Firemonkey.

Есть ли информация, как это сделать?

1 Ответ

2 голосов
/ 04 марта 2012

Не уверен, работает ли он для 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.
...