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キャンバスはカスタムフォントを実現できるような設計になっていないということです1。万事休すか……！？ 助けてマイクロソフト！ 体験版リリースに間に合わないよ！2
ということで
手段は選ばない。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節の前に次のような記述を追加します。
var
FontCollection: IUnknown = nil; // Added
ii. すべての DWriteFactory.CreateTextFormat に対して、FontCollection を指定します。
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
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した時点でカスタムフォントを利用可能になったりする代物です。
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}
さて、肝心要の、カスタムフォント読み込みクラスとかカスタムフォント列挙クラスを次に示します。
これが無いと始まるものも始まらないですからね！
{$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でフォントを追加できるように3しておき(内部のリストにTList<IDWriteFontFile>を採用)
- DirectWriteがフォントを列挙しに来たときはMoveNextで「まだあるで」「もうないで」と教えてやり
- DirectWriteが「これ欲しい！」といったときはGetCurrentFontFileにてフォントを渡してあげる
この三点セットが主な流れです。
しかし、引数を見ると分かる通りGetCurrentFontFileでリクエストが来ても「欲しいのどのフォントや！」(分からん)と一瞬思うわけですが、実はMoveNextと動作がセットなので、ここまでカウントしたぞ、ということをクラス側で覚えておけば、「これ欲しい！」と言われたときに「ああ、i番目のやつですね、はいどうぞ」と渡せるわけです。
さて、次は便利クラスの実装部です。ほぼ自分用かつ、クソ長いので必要なければ適宜スルーしてください。ただし、カスタムフォントを実現するコードをregistering関数に記述していることだけ注意してください。
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を作る
ちょっとここ注目してください。
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が使われるかどうかいった具合で、それなら、まずは最小限のシステムフォント＋カスタムフォントで立ち上げて起動を爆速化しちゃいます。例えるならセーフモード状態ですね4。
引き続いて、フルのシステムフォント＋カスタムフォントのフォントコレクションを作るため、しばらくCreateCustomFontCollectionを走らせておきます。放置プレイです。え、それ固まるんじゃない？ いえいえ、よく見てください。バックグラウンド(TAnonymousThread)で実行できるように匿名スレッドでラッピングしてあります。FontCollection書き換え時などはSynchronizeを忘れずに！
放置プレイが完了したときは、フルのシステムフォント＋カスタムフォントのフォントコレクションが出来上がっています。改めてフォントコレクションを差し替えると、見事に「2パス作戦」によるFMXでのカスタムフォントを実現することができます。
以上が、FMXにてカスタムフォントをゴリ押しで実現する手順だったのでした。長かったあああ！
問題点
お約束通り、玉に瑕なポイントはいくつかあります。
各種APIの取り扱いとスレッドセーフ
気を付けて書いたつもりですが、ミスっているところがあるようなないような……。
インターフェースにさよならを告げるとき
もう使わない時はnil代入で良いんだっけ？
CreateCustomFontCollection中にソフトが終了したら？
これが大問題。別スレッドでCreateCustomFontCollectionを動かすことで色々誤魔化しは利きました。しかし、ソフト終了時となると話は別。起動してすぐ終了するなど、CreateCustomFontCollectionから制御が返らない状態でソフト終了を試みられると、フォントコレクション作ってる最中のスレッドを安全に止める手段がありません。最強の誤魔化しとして、TerminateThreadあたりを使ってサブスレッドを殺ったりする方法もあるけれど、それすらダメな場合はAccess Violation等の例外が発生したりします。exceptで握り潰すのも……ねえ？
本当に必要ないフォントは全部弾く方向性でいくのが現状ベターかもしれません。例えば、日本語のアドベンチャーゲームでは、欧文/シンボルフォントのうち、特定のもの数個以外は確実に必要ありません。極論、欧文・シンボルは全部弾いて日本語フォントだけ読み込むのだって十分アリでしょう。
おまけ：STEP3. フォントリストの取得
DirectWriteとGDIでは指定するフォント名が微妙に違ったりします。ついでにmasOSも。
適切にフォントリストを取ってこられるようにしてみましょう。
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のカスタムフォント事情についてお送りしました。長くなってごめんね！ ではまた来年！ 何か書けたらいいな！
時空改札のフェアリーテイル、どうぞよしなに。(ダイレクトマーケティング)