VB批量安装字体!

发布网友 发布时间：2022-06-06 07:47

我来回答

共3个回答

热心网友 时间：2023-10-06 04:17

'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

热心网友 时间：2023-10-06 04:17

安装字体不需要复制字体文件
AddFontResource("c:\myApp\myFont.ttf")
这样就可以了追问AddFontResource这个方法我也调用了，可是依然是不行！不知道怎么回事！

热心网友 时间：2023-10-06 04:17

xp可以复制，win7操作c盘需要权限追问那我在运行的时候使用管理员权限运行的也不可以么？

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