使用VBSCRIPT安装字体

阅读原文时间：2023年07月16日阅读：1

　　根据新系统要求，经常要部署一些原来系统里没有的字体，原先我为了图省事经常会要求用户手动安装字体文件，虽然Windows的易用性做得相当不错，但是仍然要照顾一些不会安装字体的人，其实把这些字体打包进安装包更为方便，不过我觉得总不能每有新字体都要搞个安装包那么麻烦吧。更重要的是仍然有人会问我字体怎么安装，以前清一色的Windows XP系统，我倒也方便，直接告知打开控制面板找到字体文件夹，把要安装的字体拖进去即可；现在有Windows 7还是Windows 8等各种版本Windows系统，对于安装字体这个小小操作我也开始分情况讨论了。

　　使用VBScript脚本来实现这个功能。脚本的重点是采用Shell.ApplicationActiveX/COM对象实现复制到系统特殊文件夹下，实际上这个操作和用户手动复制到字体文件夹下一样，系统会自动为我们安装字体而不需要我们顾及注册表更新的问题，对于Vista及更高版本的系统来说，我参考了《The true ultimate font install for Windows 7 and XP vbs》的做法，使用.InvokeVerb("Install")直接调用字体文件对象的安装命令。

详细的代码如下（请复制的朋友手下留情，保留版权信息，谢谢）：

'
' File Description : VBScript Windows Fonts Installer
'
' Copyright (c) 2016-2017 Cheney_Yang. All rights reserved.
'
' Author: Cheney_Yang
' This code is distributed under the BSD license
'
' Usage:
' Drag Font files or folder to this script
' or Double click this script file, It will install fonts on the current directory
' or select font directory to install
' *** 请不要移除此版权信息 ***
'
Option Explicit

Const FONTS = &H14&
Const HKEY_LOCAL_MACHINE = &H80000002
Const strComputer = "."

Const SHELL_MY_COMPUTER = &H11
Const SHELL_WINDOW_HANDLE =
Const SHELL_OPTIONS =
Function GetOpenDirectory(title)
Dim ShlApp,ShlFdr,ShlFdrItem

Set ShlApp = WSH.CreateObject("Shell.Application")  
Set ShlFdr = ShlApp.Namespace(SHELL\_MY\_COMPUTER)  
Set ShlFdrItem = ShlFdr.Self  
GetOpenDirectory = ShlFdrItem.Path  
Set ShlFdrItem = Nothing  
Set ShlFdr = Nothing

Set ShlFdr = ShlApp.BrowseForFolder \_  
            (SHELL\_WINDOW\_HANDLE, \_  
            title, \_  
            SHELL\_OPTIONS, \_  
            GetOpenDirectory)  
If ShlFdr Is Nothing Then  
    GetOpenDirectory = ""  
Else  
    Set ShlFdrItem = ShlFdr.Self  
    GetOpenDirectory = ShlFdrItem.Path  
    Set ShlFdrItem = Nothing  
End If  
Set ShlApp = Nothing

End Function

Function IsVista()
IsVista = False
Dim objWMIService, colOperationSystems, objOperationSystem
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colOperationSystems = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")
For Each objOperationSystem In colOperationSystems
If CInt(Left(objOperationSystem.Version, )) > Then
IsVista = True
Exit Function
End If
Next
Set colOperationSystems = Nothing
Set objWMIService = Nothing
End Function

Class FontInstaller

Private objShell  
Private objFolder  
Private objRegistry  
Private strKeyPath  
Private objRegExp  
Private objFileSystemObject  
Private objDictFontFiles  
Private objDictFontNames  
Private pfnCallBack  
Private blnIsVista

Public Property Get FileSystemObject  
    Set FileSystemObject = objFileSystemObject  
End Property

Public Property Let CallBack(value)  
    pfnCallBack = value  
End Property

Private Sub Class\_Initialize()  
    strKeyPath = "Software\\Microsoft\\Windows NT\\CurrentVersion\\Fonts"

    Set objShell = CreateObject("Shell.Application")  
    Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")  
    Set objFolder = objShell.Namespace(FONTS)  
    Set objDictFontFiles = CreateObject("Scripting.Dictionary")  
    Set objDictFontNames = CreateObject("Scripting.Dictionary")  
    Set objRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}!\\\\" &\_  
                 strComputer & "\\root\\default:StdRegProv")  
    Set objRegExp = New RegExp  
        objRegExp.Global = False  
        objRegExp.Pattern = "^(\[^\\(\]+) \\(.+$"

    blnIsVista = IsVista()  
    makeFontNameList  
    makeFontFileList  
End Sub

Private Sub Class\_Terminate()  
    Set objRegExp = Nothing  
    Set objRegistry = Nothing  
    Set objFolder = Nothing  
        objDictFontFiles.RemoveAll  
    Set objDictFontFiles = Nothing  
        objDictFontNames.RemoveAll  
    Set objDictFontNames = Nothing  
    Set objFileSystemObject = Nothing  
    Set objShell = Nothing  
End Sub

Private Function GetFilenameWithoutExtension(ByVal FileName)  
    ' http://social.technet.microsoft.com/Forums/en-US/ebe19301-541a-412b-8e89-08c4263cc60b/get-filename-without-extension  
    Dim Result, i  
    Result = FileName  
    i = InStrRev(FileName, ".")  
    If ( i >  ) Then  
    Result = Mid(FileName, , i - )  
    End If  
    GetFilenameWithoutExtension = Result  
End Function

Private Sub makeFontNameList()  
    On Error Resume Next  
    Dim strValue,arrEntryNames  
    objRegistry.EnumValues HKEY\_LOCAL\_MACHINE, strKeyPath, arrEntryNames  
    For Each strValue in arrEntryNames  
       objDictFontNames.Add objRegExp.Replace(strValue, "$1"), strValue  
    Next  
    If Err.Number<> Then Err.Clear  
End Sub

Private Sub makeFontFileList()  
    On Error Resume Next  
    Dim objFolderItem,colItems,objItem  
    Set objFolderItem = objFolder.Self  
    'Wscript.Echo objFolderItem.Path  
    Set colItems = objFolder.Items  
    For Each objItem in colItems  
        objDictFontFiles.Add GetFilenameWithoutExtension(objItem.Name),objItem.Name  
    Next  
    Set colItems = Nothing  
    Set objFolderItem = Nothing  
    If Err.Number<> Then Err.Clear  
End Sub

Function getBaseName(ByVal strFileName)  
    getBaseName = objFileSystemObject.GetBaseName(strFileName)  
End Function

Public Function PathAddBackslash(strFileName)  
    PathAddBackslash = strFileName  
    If objFileSystemObject.FolderExists(strFileName) Then  
      Dim last  
      ' 文件夹存在  
      ' 截取最后一个字符  
      last = Right(strFileName, )  
      If last<>"\\" And last<>"/" Then  
        PathAddBackslash = strFileName & "\\"  
      End If  
    End If  
End Function

Public Function isFontInstalled(ByVal strName)  
    isFontInstalled = objDictFontNames.Exists(strName) Or objDictFontFiles.Exists(strName)  
End Function

Public Function isFontFileInstalled(ByVal strFileName)  
    isFontFileInstalled = isFontInstalled(objFileSystemObject.GetBaseName(strFileName))  
End Function

Public Sub installFromFile(ByVal strFileName)  
    Dim strExtension, strBaseFileName, objCallBack, nResult  
    strBaseFileName = objFileSystemObject.GetBaseName(strFileName)  
    strExtension = UCase(objFileSystemObject.GetExtensionName(strFileName))

    If Len(pfnCallBack) >  Then  
        Set objCallBack = GetRef(pfnCallBack)  
    Else  
        Set objCallBack = Nothing  
    End If

    If strExtension = "TTF" Or strExtension = "TTC" Or strExtension = "OTF" Then  
        If Not isFontInstalled(strBaseFileName) Then  
            If blnIsVista Then  
                Dim objFont, objFontNameSpace  
                Set objFontNameSpace = objShell.Namespace(objFileSystemObject.GetParentFolderName(strFileName))  
                Set objFont = objFontNameSpace.ParseName(objFileSystemObject.GetFileName(strFileName))  
                    'WSH.Echo objFileSystemObject.GetParentFolderName(strFileName)  
                    objFont.InvokeVerb("Install")  
                Set objFont = Nothing  
                Set objFontNameSpace = Nothing  
            Else  
            'WSH.Echo strFileName  
            objFolder.CopyHere strFileName  
            End If

            nResult =  
        Else  
            nResult =  
        End If  
    Else  
        nResult = -  
    End If

    If IsObject(objCallBack) Then  
        objCallBack Me, strFileName, nResult  
        Set objCallBack = Nothing

    End If  
End Sub

Public Sub installFromDirectory(ByVal strDirName)  
    Dim objFolder, colFiles, objFile  
    Set objFolder = objFileSystemObject.GetFolder(strDirName)  
    Set colFiles = objFolder.Files  
    For Each objFile in colFiles  
        If objFile.Size >  Then  
            installFromFile PathAddBackslash(strDirName) & objFile.Name  
        End If  
    Next

    Set colFiles = Nothing  
    Set objFolder = Nothing  
End Sub

Public Sub setDragDrop(objArgs)  
    ' http://msdn.microsoft.com/en-us/library/c488f3e0(v=vs.84).aspx  
    Dim i  
    For i =  to objArgs.Count -  
       If objFileSystemObject.FileExists(objArgs(i)) Then  
            installFromFile objArgs(i)  
       ElseIf objFileSystemObject.FolderExists(objArgs(i)) Then  
            installFromDirectory objArgs(i)  
       End If  
    Next  
End Sub

End Class

Sub ForceCScriptExecution()
' https://stackoverflow.com/questions/4692542/force-a-vbs-to-run-using-cscript-instead-of-wscript
' http://www.winhelponline.com/articles/185/1/VBScripts-and-UAC-elevation.html
Dim Arg, Str
If Not LCase( Right( WScript.FullName, ) ) = "\cscript.exe" Then
For Each Arg In WScript.Arguments
If InStr( Arg, " " ) Then Arg = """" & Arg & """"
Str = Str & " " & Arg
Next

    If IsVista() Then  
        CreateObject( "Shell.Application" ).ShellExecute \_  
            "cscript.exe","//nologo """ & \_  
            WScript.ScriptFullName & \_  
            """ " & Str, "", "runas",  
    Else

        CreateObject( "WScript.Shell" ).Run \_  
        "cscript //nologo """ & \_  
        WScript.ScriptFullName & \_  
        """ " & Str

    End If  
    WScript.Quit  
End If

End Sub

Sub DisplayMessage(ByRef objInstaller, ByVal strFileName, ByVal nResult)
WScript.StdOut.Write "Install " & objInstaller.getBaseName(strFileName) & " ->>> "
Select Case nResult
Case
WScript.StdOut.Write "SUCCEEDED"
Case
WScript.StdOut.Write "ALREADY INSTALLED"
Case -
WScript.StdOut.Write "FAILED (Reason: Not a Font File)"
End Select
WScript.StdOut.Write vbCrLf
End Sub

Sub Pause(strPause)
WScript.Echo (strPause)
WScript.StdIn.Read()
End Sub

Function VBMain(colArguments)
VBMain =

ForceCScriptExecution()

WSH.Echo "Easy Font Installer 1.0" & vbCrLf &\_  
          "Written By Cheney\_Yang " & vbCrLf & vbCrLf  
Dim objInstaller, objFso, objDictFontFiles  
Set objInstaller = New FontInstaller  
    objInstaller.CallBack = "DisplayMessage"  
    If colArguments.Count >  Then  
        objInstaller.setDragDrop colArguments  
    Else  
        Set objFso = objInstaller.FileSystemObject  
        Set objDictFontFiles = CreateObject("Scripting.Dictionary")  
        Dim objFolder, colFiles, objFile, strDirName, strExtension  
        strDirName = objFso.GetParentFolderName(WScript.ScriptFullName)  
        Set objFolder = objFso.GetFolder(strDirName)  
        Set colFiles = objFolder.Files  
        For Each objFile in colFiles  
            If objFile.Size >  Then  
                strExtension = UCase(objFso.GetExtensionName(objFile.Name))  
                If strExtension = "TTF" Or strExtension = "TTC" Or strExtension = "OTF" Then  
                    objDictFontFiles.Add objFile.Name, objInstaller.PathAddBackslash(strDirName) & objFile.Name  
                End If  
            End If  
        Next

        Set colFiles = Nothing  
        Set objFolder = Nothing  
        Set objFso = Nothing

        If objDictFontFiles.Count >  Then  
            If MsgBox("Current Directory has " & objDictFontFiles.Count & " Font Files." & vbCrLf &\_  
                    vbCrLf & "Click OK to continue install or Cancel to Select Directory", ) =  Then  
                  Dim i, objItems  
                  For i =  To  objDictFontFiles.Count-  
                    objItems = objDictFontFiles.Items  
                    objInstaller.installFromFile objItems(i)  
                  Next  
            Else  
                strDirName = GetOpenDirectory("Select Fonts Directory:")  
                If strDirName<>"" Then  
                    objInstaller.installFromDirectory strDirName  
                Else  
                    WScript.Echo "----- Drag Font File To This Script -----"  
                End If  
            End If  
        End If  
            objDictFontFiles.RemoveAll  
        Set objDictFontFiles = Nothing  
    End If  
Set objInstaller = Nothing

Pause vbCrLf & vbCrLf & "Press Enter to continue"

End Function

WScript.Quit(VBMain(WScript.Arguments))