安装字体并使Windows知道

我有一个函数下面将安装一个字体（ .ttf ）到Windows通过复制到Windows字体文件夹，然后触发WM_FONTCHANGE消息。 但是，该字体不能立即在Windows资源pipe理器中显示。

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

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

我以为WM_FONTCHANGE消息应该照顾这个，但显然这不是伎俩。

• 为什么在垂直方向字体大小不同
• 如何在Windows下从我的代码中删除字体？
• 在Linux FF和Windows FF中字体不一样
• Windows 7 64 Chrome 19字体反锯齿呈现问题
• Segoe UIselect：Segoe UI不支持亚洲语言

我在这个字体安装中错过了什么，以确保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

在下面的答案的评论中build议通过shell而不是Windows API来安装字体。 所以，我写了这个函数实质上完成了同样的function：

 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 （“没有应用程序与此操作的指定文件关联”）。

我也在下面的答案中尝试了特定的解决scheme，但是无济于事。 我都使用AddFontResource并写入相应的registry项 – 尝试使用此字体安装卸载/重新启动/重试的组合。