以文本方式查看主题

-  Foxtable(狐表)  (http://foxtable.com/bbs/index.asp)
--  专家坐堂  (http://foxtable.com/bbs/list.asp?boardid=2)
----  字体安装  (http://foxtable.com/bbs/dispbbs.asp?boardid=2&id=102121)
--  作者：超古伯
--  发布时间：2017/6/13 16:38:00
--  字体安装
字体安装的代码是直接拷贝字体到系统目录下的字体文件夹就可以吗?

测试了没反应，拷贝过去看不到字体文件，如果选不覆盖拷贝的话又会提示字体文件已存在

代码：

\'拷贝时间字体
Dim s As String=SpecialFolder.System & "\\fonts"
s=s.replace("system32\\","")
FileSys.CopyFile("" & path & "\\sjzt.ttf","" & s & "\\sjzt.ttf",True)

请老师指教
--  作者：有点蓝
--  发布时间：2017/6/13 17:52:00
--  
1、字体文件是隐藏的
2、系统目录没有权限写入
--  作者：超古伯
--  发布时间：2017/6/13 18:00:00
--  
可以把文件复制到剪贴板吗？好像没有setfile的属性
--  作者：有点色
--  发布时间：2017/6/13 18:40:00
--  

下面的代码，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")
--  作者：超古伯
--  发布时间：2017/6/13 19:34:00
--  
用最笨的方法解决~复制文件到剪贴板，打开字体文件夹，模拟按键ctrl+v~~~done!