InstallFonts.vbs

'
' File Description : VBScript Windows Fonts Installer
'
' Copyright (c) 2012-2013 WangYe. All rights reserved.
' 
' Author: WangYe
' Site: http://wangye.org
' This code is distributed under the BSD license
'
' For more information please visit
'   http://wangye.org/blog/archives/937/
'
' References:
' http://blogs.technet.com/b/heyscriptingguy/archive/2008/04/25/how-can-i-install-fonts-using-a-script.aspx
'
' 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://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","//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 http://wangye.org/" & 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))