windows - 安装字体并让 Windows 感知

Question

我在下面有一个函数，它通过将字体 (.ttf) 复制到 Windows 字体文件夹然后触发 WM_FONTCHANGE 消息将其安装到 Windows 中。但是，该字体不会立即在 Windows 资源管理器中可见。

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

但是我可以确认我的 .ttf 文件确实存在。使用命令提示符导航到这里，我可以看到我的字体文件。当我打开 Character Map 实用程序时，我的字体列在此处。该字体可在我的应用程序中使用。我必须重新启动 explorer.exe 才能让它显示在 Windows 资源管理器 View 中。我什至尝试以管理员身份(提升)运行我的应用程序，但仍然没有成功。

我认为 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 并编写了适当的注册表项 - 同时尝试卸载/重新启动/重试此字体安装的组合。

Answer 1

WM_FONTCHANGE 仅通知应用程序系统中有新字体，但实际上并没有告诉系统新字体是什么。

在发送 WM_FONTCHANGE 之前，您需要调用 AddFontResource将字体添加到系统字体表。如果您希望字体在重新启动后保留，您还需要向注册表项添加一个条目 HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts(请参阅 AddFontResource 的文档 获取更多信息)。