创建VBScript以从文件服务器获取字体

Question

我正在尝试创建一个VBS脚本，该脚本将从服务器字体位置获取所有字体，以便域用户能够使用它们。当我运行这个脚本时，我得到一个第15行的char 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 = "\serverFonts"
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

Answer 1

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

不管怎样，这是我从服务器共享复制和安装字体的代码，如果这对有任何帮助的话

Call AddFonts("\serverFonts")
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:WINDOWSFonts)
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