安装字体并使Windows识别

Question

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

运行此操作后,当我通过控制面板打开字体时,我的字体不会显示在那里.当我打开C:\Windows\Fonts\它时也没有显示.

但是我可以确认我的.ttf文件确实存在.使用命令提示符在这里导航,我可以看到我的字体文件.当我打开字符映射实用程序时,我的字体列在这里.并且该字体在我的应用程序中可用.我必须重新启动explorer.exe才能在Windows资源管理器视图中显示它.我甚至尝试以管理员身份运行我的应用程序(提升),但仍然没有运气.

我认为这个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');

UPDATE

在下面的答案的评论中建议通过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有关详细信息,请参阅文档).