下面的代码，win7测试无效，xp好像可以
全局代码
<DllImport("gdi32.dll")> _
Public Function AddFontResource(ByVal lpFileName As String) As Integer
End Function
<DllImport("gdi32.dll")> _
Public Function RemoveFontResource(ByVal lpFileName As String) As Integer
End Function
<DllImport("kernel32.dll")> _
Public Function WriteProfileString(ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Integer
End Function
<DllImport("user32.dll")> _
Public Function SendMessage(ByVal hWnd As Integer, ByVal Msg As UInteger, ByVal wParam As Integer, ByVal lParam As Integer) As Integer
End Function
Public Function installFont(ByVal orginFontPath As String, FontFileName As String, FontName As String) As Integer
Dim WinFontDir As String = String.Format("{0}\fonts\", System.Environment.GetEnvironmentVariable("WINDIR"))
Dim Ret As Integer = 0
Dim Res As Integer
Dim FontPath As String
Const WM_FONTCHANGE As Integer = 29
Const HWND_BROADCAST As Integer = 65535
FontPath = WinFontDir + FontFileName
Try
If io.File.Exists(FontPath) Then
removeFont(FontPath)
End If
If Not io.File.Exists(FontPath) Then
io.File.Copy(orginFontPath + FontFileName, FontPath)
Ret = AddFontResource(FontPath)
'Res = SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0)
WriteProfileString("fonts", (FontName + "(TrueType)"), FontFileName)
End If
Catch e As Exception
msgbox(e.message)
End Try
Return Ret
End Function
Public Function removeFont(ByVal FontFilePathName As String) As Integer
Try
RemoveFontResource(FontFilePathName)
io.File.Delete(FontFilePathName)
Catch e As Exception
msgbox(e.message)
Return 0
End Try
Return 1
End Function
调用代码
InstallFont("g:\", "SIMYOU.TTF", "SIMYOU")
加好友 
发短信
Post By：2017/6/13 16:38:00 [只看该作者]
