'
' 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 ExplicitConst 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,ShlFdrItemSet ShlApp = WSH.CreateObject("Shell.Application")Set ShlFdr = ShlApp.Namespace(SHELL_MY_COMPUTER)Set ShlFdrItem = ShlFdr.SelfGetOpenDirectory = ShlFdrItem.PathSet ShlFdrItem = NothingSet ShlFdr = NothingSet ShlFdr = ShlApp.BrowseForFolder _(SHELL_WINDOW_HANDLE, _title, _SHELL_OPTIONS, _GetOpenDirectory)If ShlFdr Is Nothing ThenGetOpenDirectory = ""ElseSet ShlFdrItem = ShlFdr.SelfGetOpenDirectory = ShlFdrItem.PathSet ShlFdrItem = NothingEnd IfSet ShlApp = Nothing
End FunctionFunction IsVista()IsVista = FalseDim objWMIService, colOperationSystems, objOperationSystemSet objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")Set colOperationSystems = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")For Each objOperationSystem In colOperationSystemsIf CInt(Left(objOperationSystem.Version, 1)) > 5 ThenIsVista = TrueExit FunctionEnd IfNextSet colOperationSystems = NothingSet objWMIService = Nothing
End FunctionClass FontInstallerPrivate objShellPrivate objFolderPrivate objRegistryPrivate strKeyPathPrivate objRegExpPrivate objFileSystemObjectPrivate objDictFontFilesPrivate objDictFontNamesPrivate pfnCallBackPrivate blnIsVistaPublic Property Get FileSystemObjectSet FileSystemObject = objFileSystemObjectEnd PropertyPublic Property Let CallBack(value)pfnCallBack = valueEnd PropertyPrivate 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 RegExpobjRegExp.Global = FalseobjRegExp.Pattern = "^([^\(]+) \(.+$"blnIsVista = IsVista()makeFontNameListmakeFontFileListEnd SubPrivate Sub Class_Terminate()Set objRegExp = NothingSet objRegistry = NothingSet objFolder = NothingobjDictFontFiles.RemoveAllSet objDictFontFiles = NothingobjDictFontNames.RemoveAllSet objDictFontNames = NothingSet objFileSystemObject = NothingSet objShell = NothingEnd SubPrivate Function GetFilenameWithoutExtension(ByVal FileName)' http://social.technet.microsoft.com/Forums/en-US/ebe19301-541a-412b-8e89-08c4263cc60b/get-filename-without-extensionDim Result, iResult = FileNamei = InStrRev(FileName, ".")If ( i > 0 ) ThenResult = Mid(FileName, 1, i - 1)End IfGetFilenameWithoutExtension = ResultEnd FunctionPrivate Sub makeFontNameList()On Error Resume NextDim strValue,arrEntryNamesobjRegistry.EnumValues HKEY_LOCAL_MACHINE, strKeyPath, arrEntryNamesFor Each strValue in arrEntryNames objDictFontNames.Add objRegExp.Replace(strValue, "$1"), strValueNext If Err.Number<>0 Then Err.ClearEnd SubPrivate Sub makeFontFileList()On Error Resume NextDim objFolderItem,colItems,objItemSet objFolderItem = objFolder.Self'Wscript.Echo objFolderItem.PathSet colItems = objFolder.ItemsFor Each objItem in colItemsobjDictFontFiles.Add GetFilenameWithoutExtension(objItem.Name),objItem.NameNextSet colItems = NothingSet objFolderItem = NothingIf Err.Number<>0 Then Err.ClearEnd SubFunction getBaseName(ByVal strFileName)getBaseName = objFileSystemObject.GetBaseName(strFileName)End FunctionPublic Function PathAddBackslash(strFileName)PathAddBackslash = strFileNameIf objFileSystemObject.FolderExists(strFileName) ThenDim last' 文件夹存在' 截取最后一个字符last = Right(strFileName, 1)If last<>"\" And last<>"/" ThenPathAddBackslash = strFileName & "\"End IfEnd IfEnd FunctionPublic Function isFontInstalled(ByVal strName)isFontInstalled = objDictFontNames.Exists(strName) Or objDictFontFiles.Exists(strName)End FunctionPublic Function isFontFileInstalled(ByVal strFileName)isFontFileInstalled = isFontInstalled(objFileSystemObject.GetBaseName(strFileName))End FunctionPublic Sub installFromFile(ByVal strFileName)Dim strExtension, strBaseFileName, objCallBack, nResultstrBaseFileName = objFileSystemObject.GetBaseName(strFileName)strExtension = UCase(objFileSystemObject.GetExtensionName(strFileName))If Len(pfnCallBack) > 0 ThenSet objCallBack = GetRef(pfnCallBack)ElseSet objCallBack = NothingEnd IfIf strExtension = "TTF" Or strExtension = "TTC" Or strExtension = "OTF" ThenIf Not isFontInstalled(strBaseFileName) ThenIf blnIsVista ThenDim objFont, objFontNameSpaceSet objFontNameSpace = objShell.Namespace(objFileSystemObject.GetParentFolderName(strFileName))Set objFont = objFontNameSpace.ParseName(objFileSystemObject.GetFileName(strFileName))'WSH.Echo objFileSystemObject.GetParentFolderName(strFileName)objFont.InvokeVerb("Install")Set objFont = NothingSet objFontNameSpace = NothingElse'WSH.Echo strFileName
                objFolder.CopyHere strFileNameEnd IfnResult = 0ElsenResult = 1End IfElsenResult = -1End IfIf IsObject(objCallBack) ThenobjCallBack Me, strFileName, nResultSet objCallBack = NothingEnd IfEnd SubPublic Sub installFromDirectory(ByVal strDirName)Dim objFolder, colFiles, objFileSet objFolder = objFileSystemObject.GetFolder(strDirName)Set colFiles = objFolder.FilesFor Each objFile in colFilesIf objFile.Size > 0 TheninstallFromFile PathAddBackslash(strDirName) & objFile.NameEnd IfNextSet colFiles = NothingSet objFolder = NothingEnd SubPublic Sub setDragDrop(objArgs)' http://msdn.microsoft.com/en-us/library/c488f3e0(v=vs.84).aspxDim iFor i = 0 to objArgs.Count - 1If objFileSystemObject.FileExists(objArgs(i)) TheninstallFromFile objArgs(i)ElseIf objFileSystemObject.FolderExists(objArgs(i)) TheninstallFromDirectory objArgs(i)End IfNextEnd Sub
End ClassSub 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.htmlDim Arg, StrIf Not LCase( Right( WScript.FullName, 12 ) ) = "\cscript.exe" ThenFor Each Arg In WScript.ArgumentsIf InStr( Arg, " " ) Then Arg = """" & Arg & """"Str = Str & " " & ArgNextIf IsVista() ThenCreateObject( "Shell.Application" ).ShellExecute _"cscript.exe","//nologo """ & _WScript.ScriptFullName & _""" " & Str, "", "runas", 1ElseCreateObject( "WScript.Shell" ).Run _"cscript //nologo """ & _WScript.ScriptFullName & _""" " & StrEnd IfWScript.QuitEnd If
End SubSub DisplayMessage(ByRef objInstaller, ByVal strFileName, ByVal nResult)WScript.StdOut.Write "Install " & objInstaller.getBaseName(strFileName) & " ->>> "Select Case nResultCase 0WScript.StdOut.Write "SUCCEEDED"Case 1WScript.StdOut.Write "ALREADY INSTALLED"Case -1WScript.StdOut.Write "FAILED (Reason: Not a Font File)"End SelectWScript.StdOut.Write vbCrLf
End SubSub Pause(strPause)WScript.Echo (strPause)WScript.StdIn.Read(1)
End SubFunction VBMain(colArguments)VBMain = 0ForceCScriptExecution()WSH.Echo "Easy Font Installer 1.0" & vbCrLf &_"Written By Cheney_Yang " & vbCrLf & vbCrLfDim objInstaller, objFso, objDictFontFilesSet objInstaller = New FontInstallerobjInstaller.CallBack = "DisplayMessage"If colArguments.Count > 0 ThenobjInstaller.setDragDrop colArgumentsElseSet objFso = objInstaller.FileSystemObjectSet objDictFontFiles = CreateObject("Scripting.Dictionary")Dim objFolder, colFiles, objFile, strDirName, strExtensionstrDirName = objFso.GetParentFolderName(WScript.ScriptFullName)Set objFolder = objFso.GetFolder(strDirName)Set colFiles = objFolder.FilesFor Each objFile in colFilesIf objFile.Size > 0 ThenstrExtension = UCase(objFso.GetExtensionName(objFile.Name))If strExtension = "TTF" Or strExtension = "TTC" Or strExtension = "OTF" ThenobjDictFontFiles.Add objFile.Name, objInstaller.PathAddBackslash(strDirName) & objFile.NameEnd IfEnd IfNextSet colFiles = NothingSet objFolder = NothingSet objFso = NothingIf objDictFontFiles.Count > 0 ThenIf MsgBox("Current Directory has " & objDictFontFiles.Count & " Font Files." & vbCrLf &_vbCrLf & "Click OK to continue install or Cancel to Select Directory", 1) = 1 ThenDim i, objItemsFor i = 0 To  objDictFontFiles.Count-1objItems = objDictFontFiles.ItemsobjInstaller.installFromFile objItems(i)NextElsestrDirName = GetOpenDirectory("Select Fonts Directory:")If strDirName<>"" ThenobjInstaller.installFromDirectory strDirNameElseWScript.Echo "----- Drag Font File To This Script -----"End IfEnd IfEnd IfobjDictFontFiles.RemoveAllSet objDictFontFiles = NothingEnd IfSet objInstaller = NothingPause vbCrLf & vbCrLf & "Press Enter to continue"
End FunctionWScript.Quit(VBMain(WScript.Arguments))