Option Explicit
' Installing multiple Fonts in Windows 7
Dim objShell, objFSO, wshShell
Dim strFontSourcePath, objFolder, objFont, objNameSpace, objFile, objFontsFldr, objFonts, strFonts
Const FONTS = &H14&
Set objShell = CreateObject("Shell.Application")
Set wshShell = CreateObject("WScript.Shell")
Set objFSO = createobject("Scripting.Filesystemobject")
strFontSourcePath = "F:\CustomFonts\"
set objFontsFldr = objShell.Namespace(FONTS)
Set objFonts = objFontsFldr.Self
strFonts = objFonts.Path & "\"
If objFSO.FolderExists(strFontSourcePath) Then
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
If objFSO.FileExists(strFonts & objFile.Name) Then
Wscript.Echo "Font already installed: " & objFile.Name
Else
Set objFont = objNameSpace.ParseName(objFile.Name)
objFont.InvokeVerb("Install")
Wscript.Echo "Installed Font: " & objFile.Name
Set objFont = Nothing
End If
End If
Next
Else
Wscript.Echo "Font Source Path does not exists"
Wscript.sleep 5000
End If