根据新系统要求，经常要部署一些原来系统里没有的字体，原先我为了图省事经常会要求用户手动安装字体文件，虽然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》这个帖子，找到下面的代码：
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
@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
|
仔细阅读代码后发现，这段批处理在复制字体并更新注册表后居然要重启电脑(汗~)，这种做法显然对最终用户不太友好，综合以上我决定放弃批处理的方式安装字体。
使用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
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://*.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
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文件，然后将要安装的字体或者包含字体的文件夹拖放到这个脚本文件即可，还有个方法就是直接双击脚本，然后按照提示会自动安装与脚本同路径的字体文件或者提示选择字体所在路径以便于安装。
还有一处值得注意的是：我对已经安装的字体是采取建立字体列表，然后判断当前安装的字体是否存在于字体列表，字体列表的来源是已经安装的字体在系统的注册名（存在于注册表中）和已经安装的字体文件名。唯一遗憾的是我是通过比判断安装字体的文件名是否在字体列表中来判断字体是否安装，这里的问题主要是待安装的字体文件名不一定与字体真实的名字一致，字体真实的名字是需要读取二进制字体文件从中来获取的，这样脚本又复杂了，所以放弃了这种方式。