Install Fonts VBS

This is a revamp of the previous post. It is still a little messy because I am not that familiar with VBS. This script should work for Windows 2000 up to Windows 7. The font folder directory changed in 2000 to XP. Fonts also “install” on Vista and up instead of copying.

On Error Resume Next

Dim objShell, objFSO, wshShell, objWMIService, strOS
Dim strFontSourcePath, objFolder, objFont, objNameSpace, objFile, strComputer, strOSVersion

strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
	& "{impersonationLevel=impersonate}!\\" _
	& strComputer & "\root\cimv2")
Set colOperatingSystems = objWMIService.ExecQuery _
	("Select * from Win32_OperatingSystem")
For Each objOperatingSystem in colOperatingSystems
'    Wscript.Echo objOperatingSystem.Caption & _
'    "  " & objOperatingSystem.Version
strOSVersion = left(objOperatingSystem.Version,3)
strOS = objOperatingSystem.Caption
Next

exists = InStr (strOS, "Server")
If exists = 0 Then

	Set objShell = CreateObject("Shell.Application")
	Set wshShell = CreateObject("WScript.Shell")
	Set objFSO = createobject("Scripting.Filesystemobject")

	strFontSourcePath = "\\server\Software\Fonts\"
	If objFSO.FolderExists(strFontSourcePath) Then
		If strOSVersion = "5.0" Then
			' Start 2000
			Set objNameSpace = objShell.Namespace(strFontSourcePath)
			Set objFolder = objFSO.getFolder(strFontSourcePath)
				For Each objFile In objFolder.files
					If LCase(right(objFile,4)) = ".ttf" OR LCase(right(objFile,4)) = ".otf" Then
						Set objFont = objNameSpace.ParseName(objFile.Name)
						If objFSO.FileExists("C:\WINNT\Fonts\" & objFile.Name) = False Then
							objFSO.CopyFile strFontSourcePath & objFile.Name , "C:\WINNT\fonts\"
							Set objFont = Nothing
						Else
						End If
					End If
				Next
		ElseIf strOSVersion = "5.1" Or strOSVersion = "5.2" Then
			' Start Windows XP
			Set objNameSpace = objShell.Namespace(strFontSourcePath)
			Set objFolder = objFSO.getFolder(strFontSourcePath)
				For Each objFile In objFolder.files
					If LCase(right(objFile,4)) = ".ttf" OR LCase(right(objFile,4)) = ".otf" Then
						Set objFont = objNameSpace.ParseName(objFile.Name)
						If objFSO.FileExists("C:\WINDOWS\Fonts\" & objFile.Name) = False Then
							objFSO.CopyFile strFontSourcePath & objFile.Name , "C:\WINDOWS\Fonts\"
							Set objFont = Nothing
						Else
						End If
					End If
				Next
		ElseIf strOSVersion = "6.0" Or strOSVersion = "6.1" Or strOSVersion = "6.2" Then
			' Start Vista, 08, 7, 08R2
			Set objNameSpace = objShell.Namespace(strFontSourcePath)
			Set objFolder = objFSO.getFolder(strFontSourcePath)
				For Each objFile In objFolder.files
					If LCase(right(objFile,4)) = ".ttf" OR LCase(right(objFile,4)) = ".otf" Then
						Set objFont = objNameSpace.ParseName(objFile.Name)
						If objFSO.FileExists("C:\WINDOWS\Fonts\" & objFile.Name) = False Then
							objFont.InvokeVerb("Install")
							Set objFont = Nothing
						Else
						End If
					End If
				Next
		Else
		End If
	Else
		Wscript.Echo "Font Source Path does not exists"
	End IF
Else
	'Skips the Servers
End If



Have fun and good luck scripting.