BAT批处理、VBScript批量安装字体脚本分享

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

使用特殊文件夹或者DESKTOP.INI方法

使用特殊文件夹方法

Windows保留了一种特殊文件夹引用，比如在Windows XP的情况下，新建一个文件夹，然后在文件夹重命名后缀.{645FF040-5081-101B-9F08-00AA002F954E}（注意以点号分隔），然后这个文件夹就变成了回收站的一个引用，当我们点击进去的时候实际上进去的是回收站。

好了我在想对于字体是不是也可以搞个文件夹引用，这样直接叫用户把要安装的字体拖进去即可，大家注意到这个成功的关键在于后面那段长长的ID号，那个学名叫做GUID，通常可以通过注册表查询，主要路径在于：

复制代码 代码如下:HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer

比如回收站就位于下面的注册表路径：

复制代码 代码如下:

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Desktop\NameSpace

对于字体我也在如下路径找到了：

复制代码 代码如下:

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\ControlPanel\NameSpace

字体的GUID是{D20EA4E1-3957-11d2-A40B-0C5020524152}，但是当我新建一个文件夹并且名称以.{D20EA4E1-3957-11d2-A40B-0C5020524152}（注意点号）结尾，当我点进去时却不能进入字体文件夹，于是这个想法被验证为失败。

使用Desktop.ini方法

其实建立特殊文件夹还有一个方法就是采用文件夹的Desktop.ini，抱着试试的心态，我在文件夹内部建立了Desktop.ini，内容如下：

复制代码 代码如下:

[.ShellClassInfo]

IconFile=%SystemRoot%\system32\SHELL32.dll

IconIndex=38

CLSID={D20EA4E1-3957-11d2-A40B-0C5020524152}

很遗憾，依然不能直达字体目录，所以这一种办法也是行不通的。

本着方便群众的想法，我决定做个小小的程序，当然我首先求助了万能的Google。原本想搞个桌面程序来着，也找到老外现成的代码FontReg – Windows Font Registration & Installation Utility。后来随着研究的深入，突然发现这玩意儿用批处理或者脚本实现更为简单。

CMD或BAT批处理安装字体

通常情况下字体文件夹位于C:\Windows\Fonts，转换为带环境变量的通用版本为%SystemRoot%\Fonts\，我们也许想当然的认为将字体复制到这个路径下就完成了安装，其实不然，系统安装字体不单单是将字体文件复制到这个路径下，其还进行了其他操作，比如更新注册表字体列表。通常情况下这个列表位于路径如下：

复制代码 代码如下:

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts

于是对于批处理来说，网上安装字体流程大概分为两派，首先第一步复制到Fonts文件夹，这个是公认的，第二步则有不同：一派认为应该更新注册表；另一派则倾向于使用AddFontResource这个函数。

使用AddFontResource更新系统字体列表

什么是AddFontResource函数？这是个Win32 API函数，位于gdi32.dll动态链接库上，MSDN参考见这里。我们可以编译调用这个函数，什么？“编译”？貌似和这里讲的批处理差远了吧，别急，好在这个函数签名不复杂，其有个AddFontResourceA的ANSI版本，这样给我们直接外部通过rundll32调用提供了可能，例如下面的代码片段：

复制代码 代码如下:

rundll32.exe gdi32.dll,AddFontResourceA %SystemRoot%\Fonts\字体.ttf

具体的代码如下（来源不详，将该批处理和TTF字体位于同一路径下，然后双击即可）：

复制代码 代码如下:

for /f %%a in ('dir /x /b *.ttf') do (

dir %windir%fonts%%a>nul 2>nul||(copy %%a %windir%fonts>nul 2>nul&rundll32.exe gdi32.dll,AddFontResourceA %windir%fonts%%a)

)

实际操作来看，这段代码在我的电脑上没有产生任何效果。

使用注册表更新系统字体列表

参考《Windows 7: Installing fonts via command line/script》这个帖子，找到下面的代码：

@ECHO OFF
TITLE Adding Fonts..
REM Filename: ADD_Fonts.cmd
REM Script to ADD TrueType and OpenType Fonts for Windows
REM By Islam Adel
REM 2012-01-16
 
REM How to use:
REM Place the batch file inside the folder of the font files OR:
REM Optional Add source folder as parameter with ending backslash and dont use quotes, spaces are allowed
REM example "ADD_fonts.cmd" C:\Fol编程客栈der 1\Folder 2\
 
IF NOT "%*"=="" SET SRC=%*
ECHO.
ECHO Adding Fonts..
ECHO.
FOR /F %%i in ('dir /b "%SRC%*.*tf"') DO CALL :FONT %%i
REM OPTIONAL REBOOT
REM shutdown -r -f -t 10 -c "Reboot required for Fonts installation"
ECHO.
ECHO Done!
PAUSE
EXIT
 
:FONT
ECHO.
REM ECHO FILE=%~f1
SET FFILE=%~n1%~x1
SET FNAME=%~n1
SET FNAME=%FNAME:-= %
IF "%~x1"==".otf" SET FTYPE=(OpenType)
IF "%~x1"==".ttf" SET FTYPE=(TrueType)
 
ECHO FILE=%FFILE%
ECHO NAME=%FNAME%
ECHO TYPE=%FTYPE%
 
COPY /Y "%SRC%%~n1%~x1" "%SystemRoot%\Fonts\"
reg add "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts" /v "%FNAME% %FTYPE%" /t REG_SZ /d "%FFILE%" /f
GOTO :EOF

仔细阅读代码后发现，这段批处理在复制字体并更新注册表后居然要重启电脑(汗~)，这种做法显然对最终用户不太友好，综合以上我决定放弃批处理的方式安装字体。

使用VBSCRIPT安装字体

最后我还是干回老本行，使用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) 2012-2013 WangYe. All rights reserved.

'

' Author: WangYe

' 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 = 0

Const SHELL_OPTIONS = 0

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, 1)) > 5 Then

                IsVista = True

                Exit Function

            End If

        Next

    Set colOperationSystems = Nothing

    http://www.devze.comSet objWMIService = Nothing

End Function

Class FontInstaller

    Private objshell

    Private objFolder

    Private objRegistry

    Private strKeyPath

    Private objRegExp

    Private objFileSystemObject

    Private objDictFontFiles

    Private objDictFontNames

    Private pfnCallBack

  &nbs编程客栈p; 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 > 0 ) Then

        Result = Mid(FileName, 1, i - 1)

        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<>0 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<>0 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, 1)

          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) > 0 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))

    &nAjrXSOrQANbsp;               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 = 0

            Else

                nResult = 1

            End If

        Else

            nResult = -1

        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 > 0 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 = 0 to objArgs.Count - 1

           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, 12 ) ) = "\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", 1

        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 0

            WScript.StdOut.Write "SUCCEEDED"

        Case 1

            WScript.StdOut.Write "ALREADY INSTALLED"

        Case -1

            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(1)

End Sub

Function VBMain(colArguments)

    VBMain = 0

    ForceCScriptExecution()

    WSH.Echo "Easy Font Installer 1.0" & vbCrLf &_

              "Written By WangYe " & vbCrLf & vbCrLf

    Dim objInstaller, objFso, objDictFontFiles

    Set objInstaller = New FontInstaller

        objInstaller.CallBack = "DisplayMessage"

        If colArguments.Count > 0 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 > 0 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 > 0 Then

 开发者_JS教程               If MsgBox("Current Directory has " & objDictFontFiles.Count & " Font Files." & vbCrLf &_

                        vbCrLf & "Click OK to continue install or Cancel to Select Directory", 1) = 1 Then

                      Dim i, objItems

                      For i = 0 To  objDictFontFiles.Count-1

                        objItems = objDictFontFiles.Items

                        objInstaller.installFromFile objItems(i)

                      Next

                Else

                    strDirName = GetOpenDirectory("Select Fonts Directory:")

                    If strDirName<>"" Then

                  www.devze.com;      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))

这个脚本的使用方法很简单，将上述代码保存为VBS文件，然后将要安装的字体或者包含字体的文件夹拖放到这个脚本文件即可，还有个方法就是直接双击脚本，然后按照提示会自动安装与脚本同路径的字体文件或者提示选择字体所在路径以便于安装。

还有一处值得注意的是：我对已经安装的字体是采取建立字体列表，然后判断当前安装的字体是否存在于字体列表，字体列表的来源是已经安装的字体在系统的注册名（存在于注册表中）和已经安装的字体文件名。唯一遗憾的是我是通过比判断安装字体的文件名是否在字体列表中来判断字体是否安装，这里的问题主要是待安装的字体文件名不一定与字体真实的名字一致，字体真实的名字是需要读取二进制字体文件从中来获取的，这样脚本又复杂了，所以放弃了这种方式。