BAT批處理、VBScript批量安裝字體腳本分享
更新時間：2014年07月30日 09:07:03 投稿：junjie
這篇文章主要介紹了BAT批處理、VBScript批量安裝字體腳本分享,本文介紹了幾種方法來實現(xiàn)需求,并對每一種的測試結(jié)果做了說明,需要的朋友可以參考下
根據(jù)新系統(tǒng)要求，經(jīng)常要部署一些原來系統(tǒng)里沒有的字體，原先我為了圖省事經(jīng)常會要求用戶手動安裝字體文件，雖然Windows的易用性做得相當(dāng)不錯，但是仍然要照顧一些不會安裝字體的人，其實把這些字體打包進安裝包更為方便，不過我覺得總不能每有新字體都要搞個安裝包那么麻煩吧。更重要的是仍然有人會問我字體怎么安裝，以前清一色的Windows XP系統(tǒng)，我倒也方便，直接告知打開控制面板找到字體文件夾，把要安裝的字體拖進去即可；現(xiàn)在有Windows 7還是Windows 8等各種版本W(wǎng)indows系統(tǒng)，對于安裝字體這個小小操作我也開始分情況討論了。
使用特殊文件夾或者DESKTOP.INI方法
使用特殊文件夾方法
Windows保留了一種特殊文件夾引用，比如在Windows XP的情況下，新建一個文件夾，然后在文件夾重命名后綴.{645FF040-5081-101B-9F08-00AA002F954E}（注意以點號分隔），然后這個文件夾就變成了回收站的一個引用，當(dāng)我們點擊進去的時候?qū)嶋H上進去的是回收站。
好了我在想對于字體是不是也可以搞個文件夾引用，這樣直接叫用戶把要安裝的字體拖進去即可，大家注意到這個成功的關(guān)鍵在于后面那段長長的ID號，那個學(xué)名叫做GUID，通?？梢酝ㄟ^注冊表查詢，主要路徑在于：
復(fù)制代碼 代碼如下:
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer
比如回收站就位于下面的注冊表路徑：
復(fù)制代碼 代碼如下:
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Desktop\NameSpace
對于字體我也在如下路徑找到了：
復(fù)制代碼 代碼如下:
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\ControlPanel\NameSpace
字體的GUID是{D20EA4E1-3957-11d2-A40B-0C5020524152}，但是當(dāng)我新建一個文件夾并且名稱以.{D20EA4E1-3957-11d2-A40B-0C5020524152}（注意點號）結(jié)尾，當(dāng)我點進去時卻不能進入字體文件夾，于是這個想法被驗證為失敗。
使用Desktop.ini方法
其實建立特殊文件夾還有一個方法就是采用文件夾的Desktop.ini，抱著試試的心態(tài)，我在文件夾內(nèi)部建立了Desktop.ini，內(nèi)容如下：
復(fù)制代碼 代碼如下:
[.ShellClassInfo]
IconFile=%SystemRoot%\system32\SHELL32.dll
IconIndex=38
CLSID={D20EA4E1-3957-11d2-A40B-0C5020524152}
很遺憾，依然不能直達字體目錄，所以這一種辦法也是行不通的。
本著方便群眾的想法，我決定做個小小的程序，當(dāng)然我首先求助了萬能的Google。原本想搞個桌面程序來著，也找到老外現(xiàn)成的代碼FontReg – Windows Font Registration & Installation Utility。后來隨著研究的深入，突然發(fā)現(xiàn)這玩意兒用批處理或者腳本實現(xiàn)更為簡單。
CMD或BAT批處理安裝字體
通常情況下字體文件夾位于C:\Windows\Fonts，轉(zhuǎn)換為帶環(huán)境變量的通用版本為%SystemRoot%\Fonts\，我們也許想當(dāng)然的認為將字體復(fù)制到這個路徑下就完成了安裝，其實不然，系統(tǒng)安裝字體不單單是將字體文件復(fù)制到這個路徑下，其還進行了其他操作，比如更新注冊表字體列表。通常情況下這個列表位于路徑如下：
復(fù)制代碼 代碼如下:
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts
于是對于批處理來說，網(wǎng)上安裝字體流程大概分為兩派，首先第一步復(fù)制到Fonts文件夾，這個是公認的，第二步則有不同：一派認為應(yīng)該更新注冊表；另一派則傾向于使用AddFontResource這個函數(shù)。
使用AddFontResource更新系統(tǒng)字體列表
什么是AddFontResource函數(shù)？這是個Win32 API函數(shù)，位于gdi32.dll動態(tài)鏈接庫上，MSDN參考見這里。我們可以編譯調(diào)用這個函數(shù)，什么？“編譯”？貌似和這里講的批處理差遠了吧，別急，好在這個函數(shù)簽名不復(fù)雜，其有個AddFontResourceA的ANSI版本，這樣給我們直接外部通過rundll32調(diào)用提供了可能，例如下面的代碼片段：
復(fù)制代碼 代碼如下:
rundll32.exe gdi32.dll,AddFontResourceA %SystemRoot%\Fonts\字體.ttf
具體的代碼如下（來源不詳，將該批處理和TTF字體位于同一路徑下，然后雙擊即可）：
復(fù)制代碼 代碼如下:
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)
)
實際操作來看，這段代碼在我的電腦上沒有產(chǎn)生任何效果。
使用注冊表更新系統(tǒng)字體列表
參考《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:\Folder 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
仔細閱讀代碼后發(fā)現(xiàn)，這段批處理在復(fù)制字體并更新注冊表后居然要重啟電腦(汗~)，這種做法顯然對最終用戶不太友好，綜合以上我決定放棄批處理的方式安裝字體。
使用VBSCRIPT安裝字體
最后我還是干回老本行，使用VBScript腳本來實現(xiàn)這個功能。腳本的重點是采用Shell.ApplicationActiveX/COM對象實現(xiàn)復(fù)制到系統(tǒng)特殊文件夾下，實際上這個操作和用戶手動復(fù)制到字體文件夾下一樣，系統(tǒng)會自動為我們安裝字體而不需要我們顧及注冊表更新的問題，對于Vista及更高版本的系統(tǒng)來說，我參考了《The true ultimate font install for Windows 7 and XP vbs》的做法，使用.InvokeVerb("Install")直接調(diào)用字體文件對象的安裝命令。
詳細的代碼如下（請復(fù)制的朋友手下留情，保留版權(quán)信息，謝謝）：
復(fù)制代碼 代碼如下:
'
' 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
' *** 請不要移除此版權(quán)信息 ***
'
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
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 > 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))
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","http://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
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
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文件，然后將要安裝的字體或者包含字體的文件夾拖放到這個腳本文件即可，還有個方法就是直接雙擊腳本，然后按照提示會自動安裝與腳本同路徑的字體文件或者提示選擇字體所在路徑以便于安裝。
還有一處值得注意的是：我對已經(jīng)安裝的字體是采取建立字體列表，然后判斷當(dāng)前安裝的字體是否存在于字體列表，字體列表的來源是已經(jīng)安裝的字體在系統(tǒng)的注冊名（存在于注冊表中）和已經(jīng)安裝的字體文件名。唯一遺憾的是我是通過比判斷安裝字體的文件名是否在字體列表中來判斷字體是否安裝，這里的問題主要是待安裝的字體文件名不一定與字體真實的名字一致，字體真實的名字是需要讀取二進制字體文件從中來獲取的，這樣腳本又復(fù)雜了，所以放棄了這種方式。
相關(guān)文章
用VBS實現(xiàn)監(jiān)視進程創(chuàng)建與刪除的代碼
微軟腳本中心里的例子，用到了WMI事件，抄下來備查。2011-02-02
VBS教程：函數(shù)-Len 函數(shù)...2006-11-11
VBS教程：函數(shù)-StrComp 函數(shù)...2006-11-11
文件系統(tǒng)是所有操作系統(tǒng)最重要的部分之一，腳本經(jīng)常會需要對文件及文件夾進行訪問和管理，在Vbs中對桌面和文件系統(tǒng)進行訪問的頂級對象是FileSystemObject(FSO)，這個對象特別復(fù)雜，是vbs進行文件操作的核心。2006-11-11
為大家介紹vbs屬性之size屬性，供大家學(xué)習(xí)參考。Size 屬性 對于文件，返回指定文件的字節(jié)數(shù)；對于文件夾，返回該文件夾中所有文件和子文件夾的字節(jié)數(shù)2014-05-05
VBScript把json字符串解析成json對象的2個方法
這篇文章主要介紹了VBScript把json字符串解析成json對象的2個方法,本文通過MSScriptControl.ScriptControl和jscript實現(xiàn),需要的朋友可以參考下2014-08-08
VBS教程：正則表達式簡介 -使用正則表達式...2006-11-11
這篇文章主要介紹了vbs 獲取字符串也就是截取字串,需要的朋友可以參考下2019-04-04
你一定很熟悉InputBox函數(shù)，就像熟悉MsgBox函數(shù)一樣。一般來說，剛開始接觸VBS的時候，學(xué)會的第一個函數(shù)是MsgBox，而第二個就是InputBox。2011-04-04
VBScript使用ADSI為IIS批量添加屏蔽或允許訪問的IP
用ADSI+ASP添加IP到IIS禁止訪問列表中2008-12-12