Question

VB批量安装字体！

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
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Dim WinPath As String
Dim Fname As String
Dim a() As String

Private Sub Form_Load()
Dim WinPathTmp As String
WinPathTmp = Space(25)
GetWindowsDirectory WinPathTmp, Len(WinPathTmp)
WinPath = Left(Trim(WinPathTmp), Len(Trim(WinPathTmp)) - 1)
Dim Fname As String
Fname = Dir("d:\desk\字体\font\font\*.ttf")
List1.Clear
Do
If Fname = "" Then Exit Do
List1.AddItem Fname
Fname = Dir()
Loop
MsgBox List1.ListCount & " 个文件被添加！"
ReDim a(0 To List1.ListCount - 1) As String
For i = 0 To List1.ListCount - 1
a(i) = List1.List(i)
Next
End Sub

Private Sub Command1_Click()
For i = 0 To List1.ListCount - 1
Fname = a(i)
If Fname <> "" Then
Fname = "d:\desk\字体\font\font\" & Fnam
On Error Resume Next
FileCopy Fname, WinPath & "\fonts\" & a(i)
AddFontResource Fname
End If
Next
MsgBox "恭喜，字体安装成功！", vbOKOnly + vbInformation, "系统提示" '系统重启后会自动写入注册表
End Sub
这个是我用VB写的一段批量安装字体的代码，字体虽然都被复制到了windows\fonts文件夹下了，但是依然不可用！求好心人指点这个是什么原因造成的！
不好意思啊，是根本就没有复制字体到fonts文件夹下。请懂的指导一下！

Answer 1

'win7如果复制失败修改一下登陆用户名的安全权限，可设置为最低（用户设置中有）

Option Explicit
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
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Dim WinPath As String
Dim Fname As String
Private Sub Form_Load()
    Dim WinPathTmp As String, i, arr(), flag
    WinPathTmp = Space(25)
    GetWindowsDirectory WinPathTmp, Len(WinPathTmp)
    WinPath = Left(Trim(WinPathTmp), Len(Trim(WinPathTmp)) - 1)
    flag = getfilename("d:\desk\字体\font\font\", arr, ".ttf")
    List1.Clear
    If flag Then
        For i = LBound(arr) To UBound(arr)
            List1.AddItem arr(i)
        Next
    End If
End Sub
Private Sub Command1_Click()
    Dim i
    For i = 0 To List1.ListCount - 1
        Fname = "d:\desk\字体\font\font\" & List1.List(i)
        FileCopy Fname, WinPath & "\fonts\" & List1.List(i)
        AddFontResource Fname
    Next
    If List1.ListCount > 0 Then MsgBox "恭喜，字体安装成功！", vbOKOnly + vbInformation, "系统提示" '系统重启后会自动写入注册表
End Sub
Function getfilename(pathname As String, temp, mark) As Boolean
    Dim f, n As Long
    pathname = pathname & IIf(Right(pathname, 1) = "\", "", "\")
    f = Dir(pathname, vbDirectory)
    If Len(f) = 0 Then
        Exit Function
    End If
    Do While f <> ""
        If f <> "." And f <> ".." Then
            If LCase(Right(pathname & f, 4)) = LCase(mark) Then
                n = n + 1
                ReDim Preserve temp(1 To n)
                temp(n) = f
            End If
        End If
        f = Dir()
    Loop
    If n > 0 Then getfilename = True
End Function

Answer 2

安装字体不需要复制字体文件
AddFontResource("c:\myApp\myFont.ttf")
这样就可以了

追问

AddFontResource这个方法我也调用了，可是依然是不行！不知道怎么回事！

Answer 3

xp可以复制，win7操作c盘需要权限

追问

那我在运行的时候使用管理员权限运行的也不可以么？

追答

据我所知，c盘可以操作的目录只有program files、
用AddFontResource操作这个目录试下