BAT批处理、VBScript批量安装字体脚本分享
根据新系统要求，经常要部署一些原来系统里没有的字体，原先我为了图省事经常会要求用户手动安装字体文件，虽然Windows的易用性做得相当不错，但是仍然要照顾一些不会安装字体的人，其实把这些字体打包进安装包更为方便，不过我觉得总不能每有新字体都要搞个安装包那么麻烦吧。更重要的是仍然有人会问我字体怎么安装，以前清一色的WindowsXP系统，我倒也方便，直接告知打开控制面板找到字体文件夹，把要安装的字体拖进去即可；现在有Windows7还是Windows8等各种版本Windows系统，对于安装字体这个小小操作我也开始分情况讨论了。
使用特殊文件夹或者DESKTOP.INI方法
使用特殊文件夹方法
Windows保留了一种特殊文件夹引用，比如在WindowsXP的情况下，新建一个文件夹，然后在文件夹重命名后缀.{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–WindowsFontRegistration&InstallationUtility。后来随着研究的深入，突然发现这玩意儿用批处理或者脚本实现更为简单。
CMD或BAT批处理安装字体
通常情况下字体文件夹位于C:\Windows\Fonts，转换为带环境变量的通用版本为%SystemRoot%\Fonts\，我们也许想当然的认为将字体复制到这个路径下就完成了安装，其实不然，系统安装字体不单单是将字体文件复制到这个路径下，其还进行了其他操作，比如更新注册表字体列表。通常情况下这个列表位于路径如下：
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\WindowsNT\CurrentVersion\Fonts
于是对于批处理来说，网上安装字体流程大概分为两派，首先第一步复制到Fonts文件夹，这个是公认的，第二步则有不同：一派认为应该更新注册表；另一派则倾向于使用AddFontResource这个函数。
使用AddFontResource更新系统字体列表
什么是AddFontResource函数？这是个Win32API函数，位于gdi32.dll动态链接库上，MSDN参考见这里。我们可以编译调用这个函数，什么？“编译”？貌似和这里讲的批处理差远了吧，别急，好在这个函数签名不复杂，其有个AddFontResourceA的ANSI版本，这样给我们直接外部通过rundll32调用提供了可能，例如下面的代码片段：
rundll32.exegdi32.dll,AddFontResourceA%SystemRoot%\Fonts\字体.ttf
具体的代码如下（来源不详，将该批处理和TTF字体位于同一路径下，然后双击即可）：
for/f%%ain('dir/x/b*.ttf')do(
dir%windir%fonts%%a>nul2>nul||(copy%%a%windir%fonts>nul2>nul&rundll32.exegdi32.dll,AddFontResourceA%windir%fonts%%a)
)
实际操作来看，这段代码在我的电脑上没有产生任何效果。
使用注册表更新系统字体列表
参考《Windows7:Installingfontsviacommandline/script》这个帖子，找到下面的代码：
@ECHOOFF
TITLEAddingFonts..
REMFilename:ADD_Fonts.cmd
REMScripttoADDTrueTypeandOpenTypeFontsforWindows
REMByIslamAdel
REM2012-01-16
REMHowtouse:
REMPlacethebatchfileinsidethefolderofthefontfilesOR:
REMOptionalAddsourcefolderasparameterwithendingbackslashanddontusequotes,spacesareallowed
REMexample"ADD_fonts.cmd"C:\Folder1\Folder2\
IFNOT"%*"==""SETSRC=%*
ECHO.
ECHOAddingFonts..
ECHO.
FOR/F%%iin('dir/b"%SRC%*.*tf"')DOCALL:FONT%%i
REMOPTIONALREBOOT
REMshutdown-r-f-t10-c"RebootrequiredforFontsinstallation"
ECHO.
ECHODone!
PAUSE
EXIT
:FONT
ECHO.
REMECHOFILE=%~f1
SETFFILE=%~n1%~x1
SETFNAME=%~n1
SETFNAME=%FNAME:-=%
IF"%~x1"==".otf"SETFTYPE=(OpenType)
IF"%~x1"==".ttf"SETFTYPE=(TrueType)
ECHOFILE=%FFILE%
ECHONAME=%FNAME%
ECHOTYPE=%FTYPE%
COPY/Y"%SRC%%~n1%~x1""%SystemRoot%\Fonts\"
regadd"HKLM\SOFTWARE\Microsoft\WindowsNT\CurrentVersion\Fonts"/v"%FNAME%%FTYPE%"/tREG_SZ/d"%FFILE%"/f
GOTO:EOF
仔细阅读代码后发现，这段批处理在复制字体并更新注册表后居然要重启电脑(汗~)，这种做法显然对最终用户不太友好，综合以上我决定放弃批处理的方式安装字体。
使用VBSCRIPT安装字体
最后我还是干回老本行，使用VBScript脚本来实现这个功能。脚本的重点是采用Shell.ApplicationActiveX/COM对象实现复制到系统特殊文件夹下，实际上这个操作和用户手动复制到字体文件夹下一样，系统会自动为我们安装字体而不需要我们顾及注册表更新的问题，对于Vista及更高版本的系统来说，我参考了《ThetrueultimatefontinstallforWindows7andXPvbs》的做法，使用.InvokeVerb("Install")直接调用字体文件对象的安装命令。
详细的代码如下（请复制的朋友手下留情，保留版权信息，谢谢）：
'
'FileDescription:VBScriptWindowsFontsInstaller
'
'Copyright(c)2012-2013WangYe.Allrightsreserved.
'
'Author:WangYe
'ThiscodeisdistributedundertheBSDlicense
'
'Usage:
' DragFontfilesorfoldertothisscript
' orDoubleclickthisscriptfile,Itwillinstallfontsonthecurrentdirectory
' orselectfontdirectorytoinstall
'***请不要移除此版权信息***
'
OptionExplicit
ConstFONTS=&H14&
ConstHKEY_LOCAL_MACHINE=&H80000002
ConststrComputer="."
ConstSHELL_MY_COMPUTER=&H11
ConstSHELL_WINDOW_HANDLE=0
ConstSHELL_OPTIONS=0
FunctionGetOpenDirectory(title)
DimShlApp,ShlFdr,ShlFdrItem
SetShlApp=WSH.CreateObject("Shell.Application")
SetShlFdr=ShlApp.Namespace(SHELL_MY_COMPUTER)
SetShlFdrItem=ShlFdr.Self
GetOpenDirectory=ShlFdrItem.Path
SetShlFdrItem=Nothing
SetShlFdr=Nothing
SetShlFdr=ShlApp.BrowseForFolder_
(SHELL_WINDOW_HANDLE,_
title,_
SHELL_OPTIONS,_
GetOpenDirectory)
IfShlFdrIsNothingThen
GetOpenDirectory=""
Else
SetShlFdrItem=ShlFdr.Self
GetOpenDirectory=ShlFdrItem.Path
SetShlFdrItem=Nothing
EndIf
SetShlApp=Nothing
EndFunction
FunctionIsVista()
IsVista=False
DimobjWMIService,colOperationSystems,objOperationSystem
SetobjWMIService=GetObject("winmgmts:{impersonationLevel=impersonate}!\\"&strComputer&"\root\cimv2")
SetcolOperationSystems=objWMIService.ExecQuery("Select*fromWin32_OperatingSystem")
ForEachobjOperationSystemIncolOperationSystems
IfCInt(Left(objOperationSystem.Version,1))>5Then
IsVista=True
ExitFunction
EndIf
Next
SetcolOperationSystems=Nothing
SetobjWMIService=Nothing
EndFunction
ClassFontInstaller
PrivateobjShell
PrivateobjFolder
PrivateobjRegistry
PrivatestrKeyPath
PrivateobjRegExp
PrivateobjFileSystemObject
PrivateobjDictFontFiles
PrivateobjDictFontNames
PrivatepfnCallBack
PrivateblnIsVista
PublicPropertyGetFileSystemObject
SetFileSystemObject=objFileSystemObject
EndProperty
PublicPropertyLetCallBack(value)
pfnCallBack=value
EndProperty
PrivateSubClass_Initialize()
strKeyPath="Software\Microsoft\WindowsNT\CurrentVersion\Fonts"
SetobjShell=CreateObject("Shell.Application")
SetobjFileSystemObject=CreateObject("Scripting.FileSystemObject")
SetobjFolder=objShell.Namespace(FONTS)
SetobjDictFontFiles=CreateObject("Scripting.Dictionary")
SetobjDictFontNames=CreateObject("Scripting.Dictionary")
SetobjRegistry=GetObject("winmgmts:{impersonationLevel=impersonate}!\\"&_
strComputer&"\root\default:StdRegProv")
SetobjRegExp=NewRegExp
objRegExp.Global=False
objRegExp.Pattern="^([^\(]+)\(.+$"
blnIsVista=IsVista()
makeFontNameList
makeFontFileList
EndSub
PrivateSubClass_Terminate()
SetobjRegExp=Nothing
SetobjRegistry=Nothing
SetobjFolder=Nothing
objDictFontFiles.RemoveAll
SetobjDictFontFiles=Nothing
objDictFontNames.RemoveAll
SetobjDictFontNames=Nothing
SetobjFileSystemObject=Nothing
SetobjShell=Nothing
EndSub
PrivateFunctionGetFilenameWithoutExtension(ByValFileName)
'http://social.technet.microsoft.com/Forums/en-US/ebe19301-541a-412b-8e89-08c4263cc60b/get-filename-without-extension
DimResult,i
Result=FileName
i=InStrRev(FileName,".")
If(i>0)Then
Result=Mid(FileName,1,i-1)
EndIf
GetFilenameWithoutExtension=Result
EndFunction
PrivateSubmakeFontNameList()
OnErrorResumeNext
DimstrValue,arrEntryNames
objRegistry.EnumValuesHKEY_LOCAL_MACHINE,strKeyPath,arrEntryNames
ForEachstrValueinarrEntryNames
objDictFontNames.AddobjRegExp.Replace(strValue,"$1"),strValue
Next
IfErr.Number<>0ThenErr.Clear
EndSub
PrivateSubmakeFontFileList()
OnErrorResumeNext
DimobjFolderItem,colItems,objItem
SetobjFolderItem=objFolder.Self
'Wscript.EchoobjFolderItem.Path
SetcolItems=objFolder.Items
ForEachobjItemincolItems
objDictFontFiles.AddGetFilenameWithoutExtension(objItem.Name),objItem.Name
Next
SetcolItems=Nothing
SetobjFolderItem=Nothing
IfErr.Number<>0ThenErr.Clear
EndSub
FunctiongetBaseName(ByValstrFileName)
getBaseName=objFileSystemObject.GetBaseName(strFileName)
EndFunction
PublicFunctionPathAddBackslash(strFileName)
PathAddBackslash=strFileName
IfobjFileSystemObject.FolderExists(strFileName)Then
Dimlast
'文件夹存在
'截取最后一个字符
last=Right(strFileName,1)
Iflast<>"\"Andlast<>"/"Then
PathAddBackslash=strFileName&"\"
EndIf
EndIf
EndFunction
PublicFunctionisFontInstalled(ByValstrName)
isFontInstalled=objDictFontNames.Exists(strName)OrobjDictFontFiles.Exists(strName)
EndFunction
PublicFunctionisFontFileInstalled(ByValstrFileName)
isFontFileInstalled=isFontInstalled(objFileSystemObject.GetBaseName(strFileName))
EndFunction
PublicSubinstallFromFile(ByValstrFileName)
DimstrExtension,strBaseFileName,objCallBack,nResult
strBaseFileName=objFileSystemObject.GetBaseName(strFileName)
strExtension=UCase(objFileSystemObject.GetExtensionName(strFileName))
IfLen(pfnCallBack)>0Then
SetobjCallBack=GetRef(pfnCallBack)
Else
SetobjCallBack=Nothing
EndIf
IfstrExtension="TTF"OrstrExtension="TTC"OrstrExtension="OTF"Then
IfNotisFontInstalled(strBaseFileName)Then
IfblnIsVistaThen
DimobjFont,objFontNameSpace
SetobjFontNameSpace=objShell.Namespace(objFileSystemObject.GetParentFolderName(strFileName))
SetobjFont=objFontNameSpace.ParseName(objFileSystemObject.GetFileName(strFileName))
'WSH.EchoobjFileSystemObject.GetParentFolderName(strFileName)
objFont.InvokeVerb("Install")
SetobjFont=Nothing
SetobjFontNameSpace=Nothing
Else
'WSH.EchostrFileName
objFolder.CopyHerestrFileName
EndIf
nResult=0
Else
nResult=1
EndIf
Else
nResult=-1
EndIf
IfIsObject(objCallBack)Then
objCallBackMe,strFileName,nResult
SetobjCallBack=Nothing
EndIf
EndSub
PublicSubinstallFromDirectory(ByValstrDirName)
DimobjFolder,colFiles,objFile
SetobjFolder=objFileSystemObject.GetFolder(strDirName)
SetcolFiles=objFolder.Files
ForEachobjFileincolFiles
IfobjFile.Size>0Then
installFromFilePathAddBackslash(strDirName)&objFile.Name
EndIf
Next
SetcolFiles=Nothing
SetobjFolder=Nothing
EndSub
PublicSubsetDragDrop(objArgs)
'http://msdn.microsoft.com/en-us/library/c488f3e0(v=vs.84).aspx
Dimi
Fori=0toobjArgs.Count-1
IfobjFileSystemObject.FileExists(objArgs(i))Then
installFromFileobjArgs(i)
ElseIfobjFileSystemObject.FolderExists(objArgs(i))Then
installFromDirectoryobjArgs(i)
EndIf
Next
EndSub
EndClass
SubForceCScriptExecution()
'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
DimArg,Str
IfNotLCase(Right(WScript.FullName,12))="\cscript.exe"Then
ForEachArgInWScript.Arguments
IfInStr(Arg,"")ThenArg=""""&Arg&""""
Str=Str&""&Arg
Next
IfIsVista()Then
CreateObject("Shell.Application").ShellExecute_
"cscript.exe","//nologo"""&_
WScript.ScriptFullName&_
""""&Str,"","runas",1
Else
CreateObject("WScript.Shell").Run_
"cscript//nologo"""&_
WScript.ScriptFullName&_
""""&Str
EndIf
WScript.Quit
EndIf
EndSub
SubDisplayMessage(ByRefobjInstaller,ByValstrFileName,ByValnResult)
WScript.StdOut.Write"Install"&objInstaller.getBaseName(strFileName)&"->>>"
SelectCasenResult
Case0
WScript.StdOut.Write"SUCCEEDED"
Case1
WScript.StdOut.Write"ALREADYINSTALLED"
Case-1
WScript.StdOut.Write"FAILED(Reason:NotaFontFile)"
EndSelect
WScript.StdOut.WritevbCrLf
EndSub
SubPause(strPause)
WScript.Echo(strPause)
WScript.StdIn.Read(1)
EndSub
FunctionVBMain(colArguments)
VBMain=0
ForceCScriptExecution()
WSH.Echo"EasyFontInstaller1.0"&vbCrLf&_
"WrittenByWangYe"&vbCrLf&vbCrLf
DimobjInstaller,objFso,objDictFontFiles
SetobjInstaller=NewFontInstaller
objInstaller.CallBack="DisplayMessage"
IfcolArguments.Count>0Then
objInstaller.setDragDropcolArguments
Else
SetobjFso=objInstaller.FileSystemObject
SetobjDictFontFiles=CreateObject("Scripting.Dictionary")
DimobjFolder,colFiles,objFile,strDirName,strExtension
strDirName=objFso.GetParentFolderName(WScript.ScriptFullName)
SetobjFolder=objFso.GetFolder(strDirName)
SetcolFiles=objFolder.Files
ForEachobjFileincolFiles
IfobjFile.Size>0Then
strExtension=UCase(objFso.GetExtensionName(objFile.Name))
IfstrExtension="TTF"OrstrExtension="TTC"OrstrExtension="OTF"Then
objDictFontFiles.AddobjFile.Name,objInstaller.PathAddBackslash(strDirName)&objFile.Name
EndIf
EndIf
Next
SetcolFiles=Nothing
SetobjFolder=Nothing
SetobjFso=Nothing
IfobjDictFontFiles.Count>0Then
IfMsgBox("CurrentDirectoryhas"&objDictFontFiles.Count&"FontFiles."&vbCrLf&_
vbCrLf&"ClickOKtocontinueinstallorCanceltoSelectDirectory",1)=1Then
Dimi,objItems
Fori=0To objDictFontFiles.Count-1
objItems=objDictFontFiles.Items
objInstaller.installFromFileobjItems(i)
Next
Else
strDirName=GetOpenDirectory("SelectFontsDirectory:")
IfstrDirName<>""Then
objInstaller.installFromDirectorystrDirName
Else
WScript.Echo"-----DragFontFileToThisScript-----"
EndIf
EndIf
EndIf
objDictFontFiles.RemoveAll
SetobjDictFontFiles=Nothing
EndIf
SetobjInstaller=Nothing
PausevbCrLf&vbCrLf&"PressEntertocontinue"
EndFunction
WScript.Quit(VBMain(WScript.Arguments))
这个脚本的使用方法很简单，将上述代码保存为VBS文件，然后将要安装的字体或者包含字体的文件夹拖放到这个脚本文件即可，还有个方法就是直接双击脚本，然后按照提示会自动安装与脚本同路径的字体文件或者提示选择字体所在路径以便于安装。
还有一处值得注意的是：我对已经安装的字体是采取建立字体列表，然后判断当前安装的字体是否存在于字体列表，字体列表的来源是已经安装的字体在系统的注册名（存在于注册表中）和已经安装的字体文件名。唯一遗憾的是我是通过比判断安装字体的文件名是否在字体列表中来判断字体是否安装，这里的问题主要是待安装的字体文件名不一定与字体真实的名字一致，字体真实的名字是需要读取二进制字体文件从中来获取的，这样脚本又复杂了，所以放弃了这种方式。