如何使用指定目录下的字体文件?

[waterytimes]

见过很多软件拥有私有字体文件目录,就是说不需要复制到fonts目录下,此功能如何实现,请高手帮忙.

需要此方面技术的朋友UP一下.

[道素]

加载字体使用API函数CreateScalableFontResource和AddFontResource。如果不希望使用字体，可以使用RemoveResource。加载后使用字体的方法和Windows自带的字体没有区别。使用AddFontResource加入的字体在计算机启动后不会自动加载，如果希望永久使用某字体，应该把文件拷贝到Fonts目录，并修改注册表。你可以参考微软的Knowledge Base的文章：“Q186722 OWTO: Programmatically Install a True Type Font”，这是使用FoxPro写的，但是方法适用于其他语言

[道素]

1
Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFileName As String) As Long
Dim AppPath As String
Private Sub Form_Load()
AppPath = App.Path
If Right$(AppPath, 1) <> "\" Then AppPath = AppPath + "\"
'Add the font to the Windows Font Table
AddFontResource AppPath + "myfont.ttf"
'Write something on the form
Me.AutoRedraw = True
Me.FontName = "myfont"
Me.Print "This is a test!"
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Remove the font from the Windows Font Table
RemoveFontResource AppPath + "myfont.ttf"
End Sub

2

Private Const HWND_BROADCAST = &HFFFF&
Private Const WM_FONTCHANGE = &H1D
Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Sub Form_Load()
Dim res As Long
' add the font
res = AddFontResource("C:\Fonts\Nordic__.ttf")
If res > 0 Then
' alert all windows that a font was added
SendMessage HWND_BROADCAST, WM_FONTCHANGE, 0, 0
MsgBox res & " fonts were added!"
End If
End Sub