正文
使用VBSCRIPT安装字体
小程序：扫一扫查出行【扫一扫了解最新限行尾号】
复制小程序
根据新系统要求，经常要部署一些原来系统里没有的字体，原先我为了图省事经常会要求用户手动安装字体文件，虽然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))
