时间戳

首页 > 解决方案 > 创建一个 VBScript 从文件服务器中获取字体

vbscript - 创建一个 VBScript 从文件服务器中获取字体

问题描述

我正在尝试创建一个 VBS 脚本，该脚本将从服务器字体位置获取所有字体，以便域用户能够使用它们。当我运行此脚本时，我收到第 15 行字符 1 错误：800A400C。

不确定它有什么问题，或者这个脚本是否能完成我想要它做的工作。

'On Error Resume Next
'Option Explicit
Dim objShell, objFSO, wshShell
Dim strFontSourcePath, objFolder, objFont, objNameSpace, objFile, strFontsSytem

Set objShell = CreateObject("Shell.Application")
Set wshShell = CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FilesyStemObject")

strFontSourcePath = "\\server\Fonts\"
strFontsSytem = WSHShell.SpecialFolders("Fonts") & "\"

Set objNameSpace = objShell.Namespace(strFontSourcePath)
Set objFolder = objFSO.GetFolder(strFontSourcePath)

For Each objFile In objFolder.Files
    If LCase(Right(objFile, 4)) = ".ttf" Or LCase(Right(objFile, 4)) = ".otf" Then
        Set objFont = objNameSpace.ParseName(objFile.Name)
        If objFSO.FileExists(strFontsSytem & objFile.Name) = False Then
            objFont.InvokeVerb("Install")
            Set objFont = Nothing
        End If
    End If
Next

Set objShell = Nothing
Set wshShell = Nothing
Set objFSO = Nothing
Set objNameSpace = Nothing
Set objFolder = Nothing
WScript.Quit

标签： vbscriptfonts

解决方案

错误代码 800A004C 表示找不到路径。请检查 strFontSourcePath 的存在，就像 Ansgar 所说，还要检查运行此代码的用户是否有权访问此共享。

无论如何，如果有帮助，这是我从服务器共享复制和安装字体的代码

Call AddFonts("\\server\Fonts\")
WScript.Quit

Private Sub AddFonts(strFromPath)
    ' install fonts from a server location if not already present
    Dim appShell, objShell, objFSO, colFiles, objFile, objFolder
    Dim strToPath, flags, strFile, strExt

    'SpecialFolder. See: https://technet.microsoft.com/en-us/library/ee176604.aspx
    Const FONTFOLDER = &H14&

    'CopyHere switches
    Const FOF_MULTIDESTFILES        = &H1&
    Const FOF_CONFIRMMOUSE          = &H2&
    Const FOF_SILENT                = &H4&
    Const FOF_RENAMEONCOLLISION     = &H8&
    Const FOF_NOCONFIRMATION        = &H10&
    Const FOF_WANTMAPPINGHANDLE     = &H20&
    Const FOF_ALLOWUNDO             = &H40&
    Const FOF_FILESONLY             = &H80&
    Const FOF_SIMPLEPROGRESS        = &H100&
    Const FOF_NOCONFIRMMKDIR        = &H200&
    Const FOF_NOERRORUI             = &H400&
    Const FOF_NOCOPYSECURITYATTRIBS = &H800&
    Const FOF_NORECURSION           = &H1000&
    Const FOF_NO_CONNECTED_ELEMENTS = &H2000&
    Const FOF_WANTNUKEWARNING       = &H4000&

    On Error Resume Next

    Set objFSO   = CreateObject("Scripting.FileSystemObject")
    Set objShell = Createobject("Wscript.Shell")
    Set appShell = CreateObject("Shell.Application")

    'create an object for the systems fonts folder
    Set objFolder = appShell.Namespace(FONTFOLDER)

    'make sure these paths end in  a backslash
    strFromPath = FixPath(strFromPath)
    'get the name of the system fonts folder (C:\WINDOWS\Fonts)
    strToPath = FixPath(objShell.SpecialFolders("Fonts"))

    'set flags to install as quiet as possible.
    flags = FOF_SILENT Or FOF_NOCONFIRMATION Or FOF_NOERRORUI Or _
            FOF_NOCONFIRMMKDIR Or FOF_NOCOPYSECURITYATTRIBS

    If (Not objFolder Is Nothing) Then
        If objFSO.FolderExists(strFromPath) Then
            Set colFiles = objFSO.GetFolder(strFromPath).Files
            If colFiles.Count > 0 Then
                For Each objFile In colFiles
                    strExt = objFSO.GetExtensionName(objFile.Name)
                    Select Case LCase(strExt)
                    Case "ttf", "otf"   ' can also be used for "fon", "pfm", "pfb", "afm"
                        'get the complete path and filename for this font file and check if already there
                        strFile = strToPath & objFile.Name
                        If Not (objFSO.FileExists(strFile)) Then
                            objFolder.CopyHere strFromPath & objFile.Name, flags
                        End If
                    End Select
                Next
            End If
        End If
    End If

    'cleanup objects
    Set appShell = Nothing
    Set colFiles = Nothing
    Set objFile = Nothing
    Set objFolder = Nothing
    Set objFSO = Nothing
    Set objShell = Nothing
End Sub

Private Function FixPath(sPath)
    'small helper function to ensure a path ends in a backslash
    If Len(sPath) > 0 And Right(sPath, 1) <> "\" Then
        FixPath = sPath & "\"
    Else
        FixPath = sPath
    End If
End Function

推荐阅读