　Delphi Advent Calender には今年初参加、2016年の22日目(12月22日分)を担当させていただきました長門みらいと申します。Delphiとは13年、中学2年からのお付き合いです。歳も取りました。本日はカレンダーというより、もはや読み物だとかリソースになってしまった感がありますが、ご笑覧いただけますと幸いです。

Introduction: FMXでカスタムフォントを使いたい！

　かなり突然ですが、下のスクリーンショットをご覧ください。
Copyright Ⓒ 2015- MiraiTunes, Kokonotori and Minori Fuyuzora

　どこからどう見ても、最近流行りの萌え系アドベンチャーゲームに変わりなく、しかもこの記事を書いている本人が制作したものであるというのですから、こりゃ一体何が起ころうとしているんだい？　という気持ちにはなるでしょう。そうです。宣伝です。
……いや、もちろん嘘ですけど。

　注目していただきたいのは、緑地の部分、テキストウインドウです。ここのフォント！　気付きましたか？　Windowsでは標準で入っていない、むしろ入っていたらびっくりとも言える、有志(fontopo様)によって作られたフォント「ぼくたちのゴシック2」で表示しています。

　このフォントは柔らかいアウトラインが読みやすく、ビルトインのフォント(MSゴシックなど)で表示するのと、ぼくたちのゴシック2で表示するのとでは心理的にも大きな差がありました。ぼくたちのゴシック2でいこう、ぼくたちのゴシック2でいこう、と軽く思っていた矢先、すぐさま技術的な大問題にぶち当たる……というか気付いてしまったのです。

カスタムフォントって……いいよね

見知らぬ、API

　AddFontResourceを使うような、従来の方法ではカスタムフォントが使えません！！

　従来のVCLアプリケーションでしたら、GDIキャンバスでの文字描画であるために、カスタムフォントのコードはAddFontResource/RemoveFontResourceを記述し、WM_FONTCHANGEをブロードキャストすることで実現できました。ひじょうにお手軽です。しかし、よく考えてみてください。FMXはDirect2Dキャンバス。VCLのGDIキャンバスとは訳が違います。具体的に何が違うのかといえば、DirectWriteで文字を描画しているらしいという点。うわああ謎技術きたあああ！

　アーキテクチャからして既に違っているGDIとDirect2D。Direct2Dキャンバス上では、GDIで活用していたカスタムフォント用のコード、即ちAddFontResource/RemoveFontResourceは一切意味を為しません。いや、正確には**「フォントの一覧」には反映されるのに実際には描画できない**という最強にネガティヴで訳の分からない意味を残していく結果が待っていますが、さらに厄介なのは、FMXのDirect2Dキャンバスはカスタムフォントを実現できるような設計になっていないということです¹。万事休すか……！？　助けてマイクロソフト！　体験版リリースに間に合わないよ！²

ということで

　手段は選ばない。FMXソース改造も辞さない。作品のために！　フォントのために！

ここまでのまとめと補足

スクリプトエンジンにカスタムフォントを組み込むのが目的。
上記スクリプトエンジンも当然Delphi(Firemonkey, FMX)製。本体についてはまたの機会に。
ところがFMXではカスタムフォントが利用できない？　できるという噂も？
開発環境は Windows7/10 Pro 64bit, AMD Radeon R7 240, 訳あって Delphi XE6

カスタムフォント実装に関する概要

FMXのDirect2Dキャンバスにおいて、FontCollectionを指定できるようにグローバル変数で引き出す
カスタムフォントローダー、カスタムフォントコレクションを定義
アプリケーション起動時に新規フォントコレクションを生成。
システムフォントコレクションと、カスタムフォントコレクションからフォントを取り出して新たに登録していく
引き出しておいたFontCollectionに、新しく作ったフォントコレクションを差し込み。
フォントが使えるようになる！

　キャンバスを定義するFMX.Canvas.D2D.pas、その中で使われている文字描画関連のDirectWrite APIには、実は描画に使用するフォントを渡すためのIDWriteFontCollection型の引数があります。nilを指定するとシステムフォント全てが対象になります。とにもかくにも、このデフォルトで記述されているnilを取っ払って、任意のフォントを指定できるようにしてあげる必要がありそうです。キャンバス自体は implementation 以下で隠されてしまっており、色々面倒な状況です。

インターフェースの基礎知識

このセクションでは、Direct2Dキャンバスにおいてカスタムフォントを扱いたいときのインターフェースなどを紹介していきます。

IDWriteFactory

Factoryと名の付く通り、DirectWrite関係の元締め。色々取れる。
元締めなので大量に作るタイプのものではありません。使い終わったらnilでさよならをしましょう。

IDWriteFontFile

フォントファイルの実体(というイメージ)。

IDWriteFontFileEnumerator

フォントファイルを列挙するためのインターフェース。主にカスタムフォント用で、実際にはこれを継承したクラスを作り、使えるフォントの一覧を教えてあげる必要がある。

IDWriteFont

フォントファイルの中身の実体(というイメージ)。

IDWriteFontFamily

フォントに含まれるアウトラインのバリエーション。RegularとかBoldとか。

IDWriteFontFace

フォントに含まれるアウトラインの総体(というイメージ)。

IDWriteFontCollection

フォントの寄せ集め。システムにあるフォントを集めたもの(システムフォント集)はIDWriteFactoryから取ってこれたりする。
カスタムな寄せ集めは、後述の IDWriteFontCollectionLoader を経由して一気に作り上げる。
**作り上げたら最後、フォントを追加/変更することはできない。**システムフォント集にも同じく、後からIDWriteFontFileを追加したりできない。
この記事の主人公的存在で、システムフォントとカスタムフォントを含んだIDWriteFontCollectionを作って、例のnilの場所に差し替えることでゴールとなる。

IDWriteFontCollectionLoader

DirectWriteがフォント集(IDWriteFontCollection)を作るとき、フォントデータの源泉となるインターフェース。主にカスタムフォント用で、実際にはこれを継承したクラスを作る必要がある。
ローカルディスクだけでなく、リソースやネットワークからのLoaderやEnumを作ることができれば、ある意味では超変態的なIDWriteFontCollectionを作ることができるかもしれない。

カスタムフォントを実装しよう！

という訳で、魔改造を施していきましょう。上記アドベンチャーゲームは自作のFMX製スクリプトエンジンなのは既に述べましたが、その理由はやはりクロスプラットフォーム対応と、高い拡張性を狙ってのこと。敢えて既製品を使わずにまさに1から制作する無茶プランをぶち上げておりましたが、まさかこんなところで躓くなんて思ってもみなかったわけです。

STEP1. FontCollectionを引き出す

ここからは、一部、FMXのソースを触ります。試してみたい方は、必ずバックアップを取っておいてください。

i. おもむろに FMX.Canvas.D2D.pas を開き、implementation節の前に次のような記述を追加します。

FMX.Canvas.D2D.After.pas

var
  FontCollection: IUnknown = nil; // Added

ii. すべての DWriteFactory.CreateTextFormat に対して、FontCollection を指定します。

FMX.Canvas.D2D.Before.pas

  DWriteFactory.CreateTextFormat(PChar(WS), nil, D2FontWeight(FFont.Style), D2FontStyle(FFont.Style),
    DWRITE_FONT_STRETCH_NORMAL, FFont.Size, PChar(FLocaleName), TextFormat);
  if TFillTextFlag.RightToLeft in Flags then
    TextFormat.SetReadingDirection(DWRITE_READING_DIRECTION_RIGHT_TO_LEFT);

  ...

  if Succeeded(TCanvasD2D.DWriteFactory.CreateTextFormat(
       PChar(Font.Family),
       nil,
       D2FontWeight(Font.Style),
       D2FontStyle(Font.Style),
       DWRITE_FONT_STRETCH_NORMAL,
       Font.Size,
       PChar(LocaleName),
       TextFormat)) then

FMX.Canvas.D2D.After.pas

  DWriteFactory.CreateTextFormat(PChar(WS), IDWriteFontCollection(FontCollection), D2FontWeight(FFont.Style), D2FontStyle(FFont.Style),
    DWRITE_FONT_STRETCH_NORMAL, FFont.Size, PChar(FLocaleName), TextFormat);
  if TFillTextFlag.RightToLeft in Flags then
    TextFormat.SetReadingDirection(DWRITE_READING_DIRECTION_RIGHT_TO_LEFT);

  ...

  if Succeeded(TCanvasD2D.DWriteFactory.CreateTextFormat(
       PChar(Font.Family),
       IDWriteFontCollection(FontCollection),
       D2FontWeight(Font.Style),
       D2FontStyle(Font.Style),
       DWRITE_FONT_STRETCH_NORMAL,
       Font.Size,
       PChar(LocaleName),
       TextFormat)) then

とりあえず、これで好きなFontCollectionを指定できるようになりました。このFontCollectionを書き換えるときはメインスレッドから。サブスレッドからやるときは、Synchronizeなどを通して書き換えましょう。FMXの描画処理はメインスレッドで行われています。たぶん。

STEP2. 必要なクラスを実装する

IDWriteFontCollectionLoader, IDWriteFontFileEnumerator を継承したクラスを作ります。ざっくり説明すると「俺(DirectWrite)はお前の用意したクラスを通じてカスタムフォントを列挙したり読み取ったりするから、後はよろしくぴょん」……しゃーねえなあ、という感じです。

TCustomFontRegister は単なる便利クラスです。人によっては必要ないのかも。
TCustomFontRegister をCreateした時点でカスタムフォントを利用可能になったりする代物です。

Utils.pas

type
  TCustomFontRegister = class
  private
      FFontFiles : TStrings;
      FOnRegistered : TSimpleNotify;
      FRegisterThread : TThread;
      FRegisterSuccessed : Boolean;
      FRegistered : Boolean;
      {$IFDEF MSWINDOWS}
      CL : Array [1..2] of IDWriteFontCollectionLoader;
      DFC : Array [1..2] of IDWriteFontCollection;
      {$ENDIF}
      procedure registring(AForm:TForm=nil);
      procedure unregistring();
  public
      constructor Create(AFontPaths:Array of String; Relative:Boolean=True; Finish:TSimpleNotify=nil);
      destructor Destroy; override;
      procedure ManualRegister(AForm:TForm=nil);
      procedure ManualUnRegister();
      property RegisterSuccessed:Boolean read FRegisterSuccessed;
      property Registered:Boolean read FRegistered write FRegistered;
      property RegisterThread:TThread read FRegisterThread;
      property OnRegistered:TSimpleNotify read FOnRegistered write FOnRegistered;
  end;

{$IFDEF MSWINDOWS}

  TCustomFontLoader = class(TInterfacedObject,IDWriteFontCollectionLoader)
      FFontDB : TList<IDWriteFontFile>;
      FCollectionkey : Pointer;
      FEnum : IDWriteFontFileEnumerator;
      procedure AddFont(AFont:IDWriteFontFile);
      function CreateEnumeratorFromKey(const factory: IDWriteFactory; const collectionKey: Pointer; collectionKeySize: Cardinal; out fontFileEnumerator: IDWriteFontFileEnumerator): HResult; stdcall;
      constructor Create();
      destructor Destroy; override;
  end;

  TCustomFontEnumerator = class(TInterfacedObject,IDWriteFontFileEnumerator)
      FParent : IDWriteFontCollectionLoader;
      i : Integer;
      function MoveNext(var hasCurrentFile: BOOL): HResult; stdcall;
      function GetCurrentFontFile(out fontFile: IDWriteFontFile): HResult; stdcall;
      constructor Create(AParent:IDWriteFontCollectionLoader);
      destructor Destroy; override;
  end;
{$ENDIF}

さて、肝心要の、カスタムフォント読み込みクラスとかカスタムフォント列挙クラスを次に示します。
これが無いと始まるものも始まらないですからね！

Utils.pas

{$IFDEF MSWINDOWS}
(* TCustomFontLoader *)
constructor TCustomFontLoader.Create();
begin
      inherited Create;
      FFontDB := TList<IDWriteFontFile>.Create;
end;

destructor TCustomFontLoader.Destroy;
var
      i : Integer;
begin
      for i := 0 to FFontDB.Count-1 do FFontDB[i] := nil;
      FEnum := nil;
      FFontDB.Free;

      inherited;
end;

procedure TCustomFontLoader.AddFont(AFont:IDWriteFontFile);
begin
      FFontDB.Add(AFont);
end;

function TCustomFontLoader.CreateEnumeratorFromKey(const factory: IDWriteFactory;
const collectionKey: Pointer; collectionKeySize: Cardinal;
out fontFileEnumerator: IDWriteFontFileEnumerator): HResult;
begin
      FEnum := IDWriteFontFileEnumerator(TCustomFontEnumerator.Create(Self));
      fontFileEnumerator := FEnum;
      FCollectionkey := collectionKey;
      RESULT := S_OK;
end;

(* TCustomFontEnumerator *)
function TCustomFontEnumerator.MoveNext(var hasCurrentFile: BOOL): HResult;
begin
      Inc(i);
      hasCurrentFile := i < (FParent as TCustomFontLoader).FFontDB.Count;
      RESULT := S_OK;
end;

function TCustomFontEnumerator.GetCurrentFontFile(out fontFile: IDWriteFontFile): HResult;
begin
      fontFile := (FParent as TCustomFontLoader).FFontDB[i];
      RESULT := S_OK;
end;

constructor TCustomFontEnumerator.Create(AParent:IDWriteFontCollectionLoader);
begin
      inherited Create;

      FParent := AParent;
      i := -1;
end;

destructor TCustomFontEnumerator.Destroy;
begin
      inherited;
end;

特筆すべきポイントは特にありませんが、

TCustomFontLoader.AddFontでフォントを追加できるように³しておき(内部のリストにTList<IDWriteFontFile>を採用)
DirectWriteがフォントを列挙しに来たときはMoveNextで「まだあるで」「もうないで」と教えてやり
DirectWriteが「これ欲しい！」といったときはGetCurrentFontFileにてフォントを渡してあげる

この三点セットが主な流れです。

　しかし、引数を見ると分かる通りGetCurrentFontFileでリクエストが来ても「欲しいのどのフォントや！」(分からん)と一瞬思うわけですが、実はMoveNextと動作がセットなので、ここまでカウントしたぞ、ということをクラス側で覚えておけば、「これ欲しい！」と言われたときに「ああ、i番目のやつですね、はいどうぞ」と渡せるわけです。

さて、次は便利クラスの実装部です。ほぼ自分用かつ、クソ長いので必要なければ適宜スルーしてください。ただし、カスタムフォントを実現するコードをregistering関数に記述していることだけ注意してください。

Utils.pas

constructor TCustomFontRegister.Create(AFontPaths:Array of String; Relative:Boolean=True; Finish:TSimpleNotify=nil);
var
      i : Integer;
      rp : String;
begin
      inherited Create;
      FFontFiles := TStringList.Create;

      FOnRegistered := Finish;

      rp := '';
      if Relative then rp := IncludeTrailingPathDelimiter(ExtractFileDir(ParamStr(0)));

      for i := 0 to High(AFontPaths) do FFontFiles.Add(rp+AFontPaths[i]);
      if FFontFiles.Count > 0 then registring();
end;

destructor TCustomFontRegister.Destroy;
begin
      unregistring();
      FFontFiles.Free;
      inherited;
end;

procedure TCustomFontRegister.unregistring();
{$IFDEF MACOS}
begin
      FRegistered := False;
end;
{$ELSEIF Defined(MSWINDOWS)}
var
      i : Integer;
      DF : IDWriteFactory;
begin
      if FRegistered then
      begin
            // for DirectWrite
            if GlobalUseDirect2D and (GlobalVersionWin.dwMajorVersion >= 6) then
            begin
                  DWriteCreateFactory(DWRITE_FACTORY_TYPE_SHARED, IDWriteFactory, IUnknown(DF));
                  try
                        DF.UnregisterFontCollectionLoader(CL[2]);
                        Fmx.Canvas.D2D.FontCollection := nil;
                  finally
                        DF := nil; DFC[2] := nil;
                  end;
            // for GDI
            end else
            begin
                  for i := 0 to FFontFiles.Count-1 do
                  begin
                        if FileExists(FFontFiles[i])  then
                        begin
                              RemoveFontResourceEx(PWideChar(FFontFiles[i]),FR_PRIVATE,nil);
                        end;
                  end;

                  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
            end;
      end;

      FRegistered := False;
end;
{$ENDIF}

procedure TCustomFontRegister.ManualRegister(AForm:TForm=nil);
begin
      registring(AForm);
end;

procedure TCustomFontRegister.ManualUnRegister();
begin
      unregistring();
end;

procedure TCustomFontRegister.registring(AForm:TForm=nil);
{$IFDEF MACOS}
begin
      if Assigned(FOnRegistered) then FOnRegistered(Self);
end;
{$ELSEIF Defined(MSWINDOWS)}

    procedure MethRefToMethPtr(const MethRef; var MethPtr);
    type
        TVtable = array [0 .. 3] of Pointer;
        PVtable = ^TVtable;
        PPVtable = ^PVtable;
    begin
        TMethod(MethPtr).Code := PPVtable(MethRef)^^[3];
        TMethod(MethPtr).Data := Pointer(MethRef);
    end;

    function MakeNotify(const Proc: TNotifyEventProc): TNotifyEvent;
    begin
        MethRefToMethPtr(Proc, Result);
    end;

begin
      FRegisterSuccessed := False;
      FRegistered := False;

      FRegisterThread := TThread.CreateAnonymousThread(
      procedure
      var
            i,j,k,n : Integer;
            m : Cardinal;
            DF : IDWriteFactory;
            SYS : IDWriteFontCollection;
            hr : HRESULT;
            wff : IDWriteFontFile;
            pwff : Array [0..16] of IDWriteFontFile;
            Dff : IDWriteFontFace;
            wf : IDWriteFont;
            CK : Pointer;
            FM : IDWriteFontFamily;
            FMN : IDWriteLocalizedStrings;
            FontName : Array [0..1024] of WideChar;
            GDIFont : TMemoryStream;
            exists : LongBool;
            BOOT_LIST : TStringList;
      begin

      try

      // for DirectWrite
      if GlobalUseDirect2D and (GlobalVersionWin.dwMajorVersion >= 6) then
      begin
            DWriteCreateFactory(DWRITE_FACTORY_TYPE_SHARED, IDWriteFactory, IUnknown(DF));
            try
                  BOOT_LIST := TStringList.Create;
                  CL[1] := TCustomFontLoader.Create();
                  CL[2] := TCustomFontLoader.Create();

                  with Boot_list do
                  begin
                        Add('MS Gothic');
                        Add('MS PGothic');
                        Add('MS UI Gothic');
                        Add('MS Mincho');
                        Add('MS PMincho');
                        Add('Meiryo');
                        Add('Meiryo UI');
                        Add('Segoe UI');
                        Add('Yu Gothic');
                        Add('Yu Gothic UI');
                        Add('Georgia');
                        Add('Courier New');
                        Add('Arial');
                        Add('Times New Roman');
                  end;

                  for i := 0 to FFontFiles.Count-1 do
                  begin
                        if FileExists(FFontFiles[i]) and SUCCEEDED(DF.CreateFontFileReference(PWideChar(FFontFiles[i]),nil,wff)) then
                        begin
                              for n := 1 to 2 do (CL[n] as TCustomFontLoader).AddFont(wff);
                        end;
                  end;

                  DF.GetSystemFontCollection(SYS,False);

                  // 2スキャン実施
                  for n := 1 to 2 do
                  begin
                        if SUCCEEDED(DF.RegisterFontCollectionLoader(CL[n])) then
                        begin
                              try
                                    for i := 0 to SYS.GetFontFamilyCount-1 do
                                    begin
                                          if SUCCEEDED(SYS.GetFontFamily(i,FM)) then
                                          begin
                                                // minimum filter (1 of 2 only)
                                                if (n = 1) then
                                                begin
                                                      FM.GetFamilyNames(FMN);

                                                      if SUCCEEDED(FMN.GetString(0,@FontName[0],1023)) then
                                                      begin
                                                            if Boot_list.IndexOf(StrPas(PWideChar(@FontName[0]))) < 0 then
                                                            begin
                                                                  Continue;
                                                            end;
                                                      end;
                                                end;

                                                exists := True;
                                                if (exists) then
                                                begin
                                                      for j := 0 to FM.GetFontCount-1 do
                                                      begin
                                                            FM.GetFont(j,wf);
                                                            wf.CreateFontFace(Dff);

                                                            Dff.GetFiles(m,nil);
                                                            Dff.GetFiles(m,@pwff[0]);

                                                            for k := 0 to m-1 do
                                                            begin
                                                                  if pwff[k] <> nil then (CL[n] as TCustomFontLoader).AddFont(pwff[k]);
                                                            end;

                                                      end;
                                                end;
                                          end;

                                    end;

                                    CK := Pointer(1024*n);
                                    hr := DF.CreateCustomFontCollection(CL[n],@CK,sizeof(Pointer),DFC[n]);

                                    TThread.Synchronize(TThread.CurrentThread,procedure()
                                    begin
                                          Fmx.Canvas.D2D.FontCollection := DFC[n];
                                    end);

                                    if ForceTerminate then break;

                              except

                              end;
                        end;
                  end;
            finally
                  DF.UnregisterFontCollectionLoader(CL[1]);
                  DF := nil;
                  DFC[1] := nil;
                  SYS := nil; wf := nil; wff := nil; Dff := nil; FM := nil;
                  for i := Low(pwff) to High(pwff) do pwff[i] := nil;
                  BOOT_LIST.Free;
            end;

      // for GDI
      end else
      begin
            if CompareText(TCanvasManager.DefaultCanvas.ClassName,'TCanvasGdiPlus') <> 0 then exit;

            for i := 0 to FFontFiles.Count-1 do
            begin
                  if FileExists(FFontFiles[i]) and (LowerCase(ExtractFileExt(FFontFiles[i])) = '.ttf') then
                  begin
                        if AForm <> nil then
                        begin
                              GDIFont := TMemoryStream.Create;
                              try
                                    GDIFont.LoadFromFile(FFontFiles[i]); GDIFont.Seek(0,0);
                                    AForm.Canvas.LoadFontFromStream(GDIFont);
                              finally
                                    GDIFont.Free;
                              end;
                        end;

                        if (AForm = nil) then AddFontResourceEx(PWideChar(FFontFiles[i]),FR_PRIVATE,nil);
                  end;
            end;

            if (AForm = nil) then SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
      end;

      except
      end;

      end);

      with FRegisterThread do
      begin
            OnTerminate := MakeNotify(
                procedure(Sender: TObject)
                begin
                      FRegisterSuccessed := True;
                      FRegistered := True;
                      FRegisterThread := nil;
                      if Assigned(FOnRegistered) then FOnRegistered(Sender);
                end);

            FreeOnTerminate := True;
            Start;
      end;

end;
{$ENDIF}

長々とありがとうございました。実はこの便利クラスの中に、小技と問題がけっこう混ざっています。いくつか紹介しましょう。

こっそりGDI対応コードが混ぜてある

registring() や unregistring() では、こっそり、GDI用の、いわゆる従来のカスタムフォント用コードが入れてあります。XP以前ではDirectWriteが使えませんので、フォールバックされる可能性があるGDI+のために用意しました。でもこれ、実際にGDI+キャンバスでは使えなかったような気がしないでもない……？　なおWindowsのFMXでは基本的にDirect2DかGDI+で、GDIは使われません。

こっそりWindows/macOS対応プリプロセッサが混ぜてある

macOSでのカスタムフォントは、app内にフォントを配置するだけで実現することができて、このクラス自体が不要です。
メインユニット側で「macOSの場合はクラスを作らない」をやっても良かったのですが、ここではクラス内部で切り分けています。

カスタムフォントの登録処理

registring()内はスパゲティコードならぬ、うどんコードというかきしめんコードというか、美味しいんだけどたぶんそれ秘伝のタレのせいのじゃないかい？　みたいな解読のしづらさになっています。申し訳ない。

基本的な流れとしては、

システムフォント集へ直接フォントを追加できたら最高だけど出来ないので、一工夫
先ほどのカスタムフォントローダーで好きなフォントを読み込んでGO! → カスタムフォントは入るけどシステムフォントが全部使えない
そこで、カスタムフォントに加えてシステムフォントも追加。システムフォント追加の際は、予め取得できるシステムフォント集からフォントファミリーなどを辿っていき、最終的にフォントファイルの実体(のようなもの)、IDWriteFontFileをゲットする必要がある
これでOK！

とても遅い

実装できたことは良いものの、前述の「基本的な流れ」で単純に実装して動かすとなぜだかCreateCustomFontCollectionでフォント集を作ってもらうのに相当な時間がかかり、もしソフト起動時にフォント登録完了待ちとかやっちゃうと地獄のような待ち時間が発生することがあります。マシンスペックによってはフリーズに近い状態になることも。怖っ！

理由は単純で、

このご時世、どのコンピューターでも、システムに入っているフォント自体がとにかく多い (欧文・和文・シンボル)
そんな状況下、システムフォントの総体は著しく巨大であり、システムフォント全てと必要なカスタムフォントを追加したローダーを IDWriteFactory.CreateCustomFontCollection に渡すと処理待ちでしばらく制御が帰ってこない

今度こそ詰んだか……？　万策尽きたか？　いや、まだだ！

二段階に分けてFontCollectionを作る

ちょっとここ注目してください。

Utils.pas

                  with Boot_list do
                  begin
                        Add('MS Gothic');
                        Add('MS PGothic');
                        Add('MS UI Gothic');
                        Add('MS Mincho');
                        Add('MS PMincho');
                        Add('Meiryo');
                        Add('Meiryo UI');
                        Add('Segoe UI');
                        Add('Yu Gothic');
                        Add('Yu Gothic UI');
                        Add('Georgia');
                        Add('Courier New');
                        Add('Arial');
                        Add('Times New Roman');
                  end;
// 中略
                                                // minimum filter (1 of 2 only)
                                                if (n = 1) then
                                                begin
                                                      FM.GetFamilyNames(FMN);

                                                      if SUCCEEDED(FMN.GetString(0,@FontName[0],1023)) then
                                                      begin
                                                            if Boot_list.IndexOf(StrPas(PWideChar(@FontName[0]))) < 0 then
                                                            begin
                                                                  Continue;
                                                            end;
                                                      end;
                                                end;

　何やら怪しい文字列の羅列がありますね。そして、後に現れるループの中では、何やら、このリストを使って何かやっている模様。

　そう！　ソフトウェアの一般的な性質に目を付けます。拙作のアドベンチャーゲームにしろ、他のユーティリティソフトにしろ、実際に使うシステムフォントは限られていますよね。欧文フォントなんてのも、Arial,Verdana,Tahoma,Courier Newが使われるかどうかいった具合で、それなら、まずは最小限のシステムフォント＋カスタムフォントで立ち上げて起動を爆速化しちゃいます。例えるならセーフモード状態ですね⁴。

　引き続いて、フルのシステムフォント＋カスタムフォントのフォントコレクションを作るため、しばらくCreateCustomFontCollectionを走らせておきます。放置プレイです。え、それ固まるんじゃない？　いえいえ、よく見てください。バックグラウンド(TAnonymousThread)で実行できるように匿名スレッドでラッピングしてあります。FontCollection書き換え時などはSynchronizeを忘れずに！

　放置プレイが完了したときは、フルのシステムフォント＋カスタムフォントのフォントコレクションが出来上がっています。改めてフォントコレクションを差し替えると、見事に「2パス作戦」によるFMXでのカスタムフォントを実現することができます。

　以上が、FMXにてカスタムフォントをゴリ押しで実現する手順だったのでした。長かったあああ！

問題点

　お約束通り、玉に瑕なポイントはいくつかあります。

各種APIの取り扱いとスレッドセーフ

　気を付けて書いたつもりですが、ミスっているところがあるようなないような……。

インターフェースにさよならを告げるとき

　もう使わない時はnil代入で良いんだっけ？

CreateCustomFontCollection中にソフトが終了したら？

　これが大問題。別スレッドでCreateCustomFontCollectionを動かすことで色々誤魔化しは利きました。しかし、ソフト終了時となると話は別。起動してすぐ終了するなど、CreateCustomFontCollectionから制御が返らない状態でソフト終了を試みられると、フォントコレクション作ってる最中のスレッドを安全に止める手段がありません。最強の誤魔化しとして、TerminateThreadあたりを使ってサブスレッドを殺ったりする方法もあるけれど、それすらダメな場合はAccess Violation等の例外が発生したりします。exceptで握り潰すのも……ねえ？

　本当に必要ないフォントは全部弾く方向性でいくのが現状ベターかもしれません。例えば、日本語のアドベンチャーゲームでは、欧文/シンボルフォントのうち、特定のもの数個以外は確実に必要ありません。極論、欧文・シンボルは全部弾いて日本語フォントだけ読み込むのだって十分アリでしょう。

おまけ：STEP3. フォントリストの取得

DirectWriteとGDIでは指定するフォント名が微妙に違ったりします。ついでにmasOSも。
適切にフォントリストを取ってこられるようにしてみましょう。

Utils.pas

function EnumFontFamProc(var EnumLogFont: TLogFont; var NewTextMetric: TNewTextMetric; FontType: Integer; LPARAM: Longint): Integer; stdcall; export;
var
      AFontName : String;
begin
      Result := 1;

      AFontName := StrPas(PWideChar(@EnumLogFont.lfFaceName[0]));

      if (pos('@',AFontName)=0) and (FontType = TRUETYPE_FONTTYPE) then
      begin
            TStrings(LPARAM).Add(AFontname);
      end;
end;

procedure GetFontList(List:TStrings);
var
      DC:HDC;
      DF : IDWriteFactory;
      DFC : IDWriteFontCollection;
      FM : IDWriteFontFamily;
      FMN : IDWriteLocalizedStrings;
      FontName : Array [0..1024] of WideChar;
      i : Integer;
      j : Cardinal;
      locname : Array [0..10] of WideChar;
      exists : LongBool;
      lf:tagLOGFONTW;
begin
      // for DirectWrite
      if GlobalUseDirect2D then
      begin
            DWriteCreateFactory(DWRITE_FACTORY_TYPE_SHARED, IDWriteFactory, IUnknown(DF));
            try
                  DFC := IDWriteFontCollection(FMX.Canvas.D2d.FontCollection);
                  if DFC = nil then DF.GetSystemFontCollection(DFC,false);

                  for i := 0 to DFC.GetFontFamilyCount-1 do
                  begin
                        DFC.GetFontFamily(i,FM);
                        FM.GetFamilyNames(FMN);
                        locname := 'ja-jp'+#0;
                        FMN.FindLocaleName(locname[0],j,exists);
                        if (exists) then
                        begin
                              FMN.GetString(j,@FontName[0],Length(FontName)-1);
                              List.Add(StrPas(PWideChar(@FontName[0])));
                        end;
                  end;
            finally
                  DF := nil;
            end;

      // for GDI
      end else
      begin
            DC := GetDC(0);
            try
                  FillMemory(@lf,sizeof(lf),0);
                  lf.lfCharSet := SHIFTJIS_CHARSET;
                  lf.lfPitchAndFamily := 0;
                  FillChar(lf.lfFaceName, sizeof(lf.lfFaceName), 0);
                  EnumFontFamiliesEx(DC, lf, @EnumFontFamProc, LongInt(List), 0);
            finally
                  ReleaseDC(0, DC);
            end;
      end;

end;
{$ENDIF}

{$IFDEF MACOS}
procedure GetFontList(List:TStrings);
var
      fm: NSFontManager;
      fa: NSArray;
      i: Integer;
      fname: NSString;
begin
      fm := TNSFontManager.Wrap(TNSFontManager.OCClass.sharedFontManager);
      fa := fm.availableFontFamilies;

      for i := 0 to fa.count-1 do
      begin
            fname := TNSString.Wrap(fa.objectAtIndex(i));
            List.Add(fname.UTF8String);
      end;
end;
{$ENDIF}

DirectWrite: フォントファミリー辺りから名前を得ます。
GDI: 定番のやつですね。EnumFontFamiliesEx API を使います。
macOS: TNSFontManagerのavailableFontFamiliesより列挙していきます。

ソースコードのライセンス

　MIT License ってことで、どうっすか？

さいごに

　当初、実装するにあたってタカをくくっていたFMXでのカスタムフォント。ところが、日本はもちろん、海外のフォーラムやStackOverflowを覗いても「無理やぞそれ……(意訳)」のAnswerばかり。頭を抱えて一ヶ月二ヶ月……ふと解決の道筋が立ってきたときは、ガッツポーズをしたものです。

　FMX製かつ、このカスタムフォントを組み込んだ拙作のADV『時空改札のフェアリーテイル』(最初にお見せしたものですね)は、他の不具合も発生したり紆余曲折あったものの、現在はほぼStableに達し、続編にまで利用できる程度には汎用化も進みました。さらに、macOSの方でもプレイできるのが個人的な推しです。まったく、Delphiは最高だぜ！

　以上、名古屋生まれ・名古屋育ちの流浪のプログラマー、長門みらいがFMXのカスタムフォント事情についてお送りしました。長くなってごめんね！　ではまた来年！　何か書けたらいいな！

時空改札のフェアリーテイル、どうぞよしなに。(ダイレクトマーケティング)

少なくともXE6ではダメ。それ以降は知らん。 ↩
おかげさまで昨年冬、間に合いました。 ↩
IDWriteFontFile 自体は IDWriteFactory.CreateFontFileReference でお手軽に作ることができます。 ↩
Windowsのセーフモードって実際のところ起動速くないよね ↩