安装字体并让Windows识别

Question

我有下面的一个函数，用于通过将字体 (.ttf) 复制到 Windows 字体文件夹中并触发 WM_FONTCHANGE 消息来安装字体。然而，在 Windows Explorer 中，该字体不会立即显示出来。

运行后，当我通过控制面板打开字体时，我的字体不会显示在那里。当我打开 C:\Windows\Fonts\ 时，它也不会显示在那里。

但是，我可以确认我的 .ttf 文件确实存在。在命令提示符中导航到此处，我可以看到我的字体文件。当我打开字符映射工具时，我的字体出现在列表中。并且该字体可在我的应用程序中使用。我必须重新启动 explorer.exe 才能在 Windows Explorer 视图中显示它。我甚至尝试以管理员身份 (提升) 运行我的应用程序，但还是没有成功。

我认为 WM_FONTCHANGE 消息应该能解决这个问题，但显然这并没有起作用。

在进行字体安装时，我缺少了什么步骤，以确保 Windows 能够识别它？

uses
  SysUtils, ShlObj, ComObj, ActiveX;

function SystemDir(Handle: THandle; Folder: Integer): String;
var
  R: HRESULT;
  PIDL: PItemIDList;
  Path: array[0..MAX_PATH] of Char;
begin
  Result:= '';
  R:= SHGetSpecialFolderLocation(Handle, Folder, PIDL);
  if R = S_OK then begin
    if SHGetPathFromIDList(PIDL, Path) then
      Result:= StrPas(Path);
  end;
end;

function InstallFont(Handle: THandle; const Filename: String): Boolean;
var
  Dir, FN: String;
begin
  Result:= False;
  FN:= ExtractFileName(Filename);
  Dir:= IncludeTrailingPathDelimiter(SystemDir(Handle, CSIDL_FONTS));
  Result:= FileExists(Filename);
  if Result then begin
    Result:= CopyFile(PChar(Filename), PChar(Dir + FN), False);
  end;
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;

使用方法：

Result:= InstallFont(Application.Handle, 'C:\MyTestFont.ttf');

更新

在下面的回答评论中建议通过shell而不是Windows API安装字体。因此，我编写了这个函数来实现基本相同的功能：

function InstallFont2(Handle: THandle; const Filename: String): Boolean;
var
  R: HINST;
begin
  Result:= False;
  R:= ShellExecuteW(Handle, 'install', PWideChar(Filename), nil, nil, SW_HIDE);
  Result:= R > 32;
end;

然而，这也存在问题。返回值为31（表示出现错误），当我调用GetLastError时，它告诉我1155（"没有与此操作指定的文件相关联的应用程序。"） 我还尝试了下面答案中的特定解决方法，但没有成功。我既使用了AddFontResource并编写了适当的注册表键，同时尝试了安装/卸载/重新尝试该字体安装的组合。

- Jerry Dodge

---

让这次成为你最后一次调用 ShellExecute。它的错误处理是无用的。你为什么要调用 GetLastError？文档中哪里说要这样做了呢？ShellExecute 只存在于与旧程序兼容的情况下。你应该调用 ShellExecuteEx。不管怎样，你需要提升权限才能执行此操作吗？ - David Heffernan

ShellExecute 可以执行在文件类上定义的动作。但是在这种情况下会失败，因为真正类型字体（ttffile）的文件类没有直接定义动作。它实现了 IContextMenu 并将其他项注入到右键菜单中，其中之一是动作“install”，但只能通过 IContextMenu::InvokeCommand 调用。ShellExecute 不知道如何执行此操作。然而，这可能并不是您想要的，因为无法关闭用户交互，包括提示是否删除字体等。 - Jonathan Gilbert

Answer 1

WM_FONTCHANGE 只通知应用程序系统中有新字体，但它并不会告诉系统新的字体是什么。

在发送 WM_FONTCHANGE 之前，你需要调用AddFontResource 将字体添加到系统字体表中。如果你想要该字体在重启后仍然保留，请还需将一个条目添加到注册表键 HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts（查看AddFontResource文档获取更多信息）。

- Jonathan Potter

---

o0o... 我以为 AddFontResource 只是每个进程实例。 - Jerry Dodge

@JerryDodge：你考虑的是AddFontMemResourceEx()，因为"通过AddFontMemResourceEx添加的字体始终是私有的，只能由调用该函数的进程使用，而不可枚举。" 或者也许使用带有FR_PRIVATE标志的 AddFontResourceEx()："指定只有调用AddFontResourceEx函数的进程才能使用此字体。" - Remy Lebeau

还没有接受，因为我仍然没有成功... 仍在努力弄清楚我哪里出了问题。在调用此消息之前，我已经成功地调用了AddFontResource并成功地编写了这个注册表项，但Windows Explorer仍然不想显示它。更不用说要检测要注册的名称是什么了... 当我通过其他软件（包括文件本身）安装它时，它可以正常安装。我想这里仍然有一些缺失的部分。 - Jerry Dodge

一个更简单的方法是只需使用 shell 安装它，使用 ShellExecuteEx 和 "install" 动词。 - Jonathan Potter

使用 ShellExecuteW(Handle, 'install', PWideChar(Filename), nil, nil, SW_HIDE) 返回了 31（表示出现错误），并且 GetLastError 告诉我 1155（"未为此操作关联指定文件的应用程序。"）。嗯，这似乎不对... 是否必须通过 ShellExecuteEx 进行操作？ - Jerry Dodge

Answer 2

我刚刚追踪了Windows 7安装字体的过程，以下是总结：

• 如果字体是TrueType字体，并且其名称尾部没有“（TrueType）”，则将其添加上。
• 如果字体已经存在，则可以卸载它以便重新安装：
  • 调用RemoveFontResourceW。
  • 从SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts中删除描述字体的注册表项（如果有）。
• 获取要安装的文件名，如果Fonts目录中已经存在该文件名，则通过重复将1添加到计数器并格式化“basename_X.ttf”来扫描唯一的文件名，其中X是十六进制数字。例如，如果“myfont_1.ttf”到“myfont_9.ttf”已经存在，则会尝试下一个文件名“myfont_A.ttf”。
• 将提供的文件复制到此空闲文件名标识符。
• 对目标路径调用AddFontResourceW。
• 根据带“（TrueType）”后缀的字体名称在SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts中编写一个条目，该条目的值为不带路径的目标文件名。
• 进行一个我无法完全理解的操作，创建一个PropertyStore并将许多值放入其中。我不确定它到底如何处理结果属性存储，但它称之为FID。
• 通过调用Sleep等待2秒钟。
• 调用PostMessageW(HWND_BROADCAST, WM_SETTINGSCHANGE, NULL, L"fonts")。
• 调用PostMessageW(HWND_BROADCAST, WM_FONTCHANGE, NULL, NULL)。
• 调用SHGetSpecialFolderLocation(CSIDL_FONTS)，然后将结果的IDLIST传递给SHChangeNotify(SHCNE_UPDATEDIR, SHCNF_IDLIST, idlist, NULL)。

我怀疑这最后三个步骤对于使系统在其他应用程序和字体文件夹中识别新字体至关重要。

- Jonathan Gilbert