Ultimate Install Font VBS

Just set the path(s) you want to install fonts from and it will search that fold and all subfolders for TTF, OTF, PFM, FON files and install them automatically. 

This will also generate a flie list of the installed font files in your windows\temp folder.  This is good to inventory what fonts a system has. You can point this to a network location or DB entries for your own purposes...

 Const FONTS = &H14&
 Const ForAppending = 8
 Dim fso
 doexist = 0
 dontexist = 0
 Set objShell = CreateObject("Shell.Application")
 Set objFolder = objShell.Namespace(FONTS)
 set oShell = CreateObject("WScript.Shell") 
 strSystemRootDir = oshell.ExpandEnvironmentStrings("%systemroot%")
 strFontDir = strSystemRootDir & "\fonts\"
 strTempDir = oshell.ExpandEnvironmentStrings("%systemroot%") & "\temp"
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set objDictionary = CreateObject("Scripting.Dictionary")
 objDictionary.CompareMode = TextMode
 Set f1 = FSO.createTextFile(strTempDir & "\installed_fonts.txt", ForAppending)
 
 CollectFonts
 InstallFonts "C:\Install\"          ' insert path here to font folder
 
 wscript.echo doexist & " fonts already installed." & vbcrlf & dontexist & " new fonts installed."
 
 '===================================================================
 Public Sub CollectFonts
 '===================================================================
 set colItems = objfolder.Items
 For each ObjItem in ColItems
    If LCase(Right(objItem.Name, 3)) = "ttf" or _
       LCase(Right(objItem.Name, 3)) = "otf" or _
       LCase(Right(objItem.Name, 3)) = "pfm" or _
       LCase(Right(objItem.Name, 3)) = "fon" Then
        If Not objDictionary.Exists(LCase(ObjItem.Name)) Then
            objDictionary.Add LCase(ObjItem.Name), LCase(ObjItem.Name)
        End If
    End If
 Next
 For each ObjItem in ObjDictionary
    f1.writeline ObjDictionary.Item(objItem)
 Next
 End Sub
 
 '===================================================================
 Public Sub InstallFonts(Folder)
 '===================================================================
 Set FontFolder = fso.getfolder(Folder)
        For Each File in FontFolder.Files
             If LCase(fso.GetExtensionName(File))="ttf" or _
                LCase(fso.GetExtensionName(File))="otf" or _
                LCase(fso.GetExtensionName(File))="pfm" or _
                LCase(fso.GetExtensionName(File))="fon" Then
 'check if Font is Already installed. If not, Install
                If objDictionary.Exists(lcase(fso.GetFileName(File))) then
 '                    wscript.echo fso.GetFileName(File) & " already exists in " & strFontDir
                    doexist = doexist + 1
                Else
 '                    wscript.echo fso.GetAbsolutePathName(File) & " doesn't exists in " & strFontDir
                    objFolder.CopyHere FontFolder & "\" & fso.GetFileName(File)
                    dontexist = dontexist + 1
                end If
            End If
        Next
        For Each SubFolder in FontFolder.subFolders
            InstallFonts SubFolder
        Next
 End Sub
 
 

Thanks for sharing. If I might make one suggestion, you may want to change your extension comparison code to not be case sensitive.

I set everything to be Lower Case, so that i could easily compare since case insensitive would be more coding. sometimes the fonts have lowercase name and uppercase extension, so i just set it all to LCase. The dictionary add is set to force LCase as well.
 
did i miss something?

This If-Then:

           If fso.GetExtensionName(File)="ttf" or _
               fso.GetExtensionName(File)="otf" or _
               fso.GetExtensionName(File)="pfm" or _
               fso.GetExtensionName(File)="fon"

Would fail for files with upper case extensions. So, for a new font it would never even get checked to see if it was in the dictionary at all.

doh,

i fixed it in my production one, but forgot to update this one before i posted...



 
original code updated...

Thank you for posting this script as it was just what i needed today and is working like a charm.

Thanks again

cjwallace


Thank you for posting this script as it was just what i needed today and is working like a charm.

Thanks again

you're welcome!
 
glad it helped someone.  I've been using it since I created it to handle our brand standard fonts for our firm.  It's so easy, we can just give it to the users and let them run on their own.

I know this post is old, but this script is exactly what I need...it just isn't working quite like it should (I think.)

The script is installing fonts, but it gives a popup for fonts already installed...and it seems like the pop ups are for the same fonts multiple times...I'm new to vbscript, but it looks like there's a "not exist" in there...so I would think this isn't supposed to happen.

Suggestions?

dangerjosh


I know this post is old, but this script is exactly what I need...it just isn't working quite like it should (I think.)

The script is installing fonts, but it gives a popup for fonts already installed...and it seems like the pop ups are for the same fonts multiple times...I'm new to vbscript, but it looks like there's a "not exist" in there...so I would think this isn't supposed to happen.

Suggestions?

the code is commented out to display the dialogs for each font.  perhaps you uncommented these wscript.echo lines.
 
 
please verify the ' is in front of the wscript.echo lines below....
 
'check if Font is Already installed. If not, Install
                If objDictionary.Exists(lcase(fso.GetFileName(File))) then
 '                    wscript.echo fso.GetFileName(File) & " already exists in " & strFontDir
                    doexist = doexist + 1
                Else
 '                    wscript.echo fso.GetAbsolutePathName(File) & " doesn't exists in " & strFontDir
                    objFolder.CopyHere FontFolder & "\" & fso.GetFileName(File)
                    dontexist = dontexist + 1
                end If
            End If

 

Hi i need your help ..
I would like to send this script via VBS to computers on my network.
I tried copy your script to remote computer and run it as remote admin..
 
But it isn work correct..:( and i don't know how to do it...
I make this...
 
On Error Resume Next
Const FOR_READING = 1
Const OverwriteExisting = TRUE    
strComputer = "computers.txt"
font1 = "I:\VBS\Fonts\fontinstall.vbs"
font1file = "fontinstall.vbs"
font2 = "I:\VBS\Fonts\instal.bat"
font2file = "instal.bat"

Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(strComputer) Then
Set objTextStream = objFSO.OpenTextFile(strComputer, FOR_READING)
Else
WScript.Echo "chybi computers.txt :o("
Wscript.Quit
End if

Do Until objTextStream.AtEndOfStream
strComputer = objTextStream.ReadLine
WScript.Echo VbCrLf & strComputer
WScript.Echo String(Len(strComputer), "-")
const HKEY_LOCAL_MACHINE = &H80000002
Set objFSO=CreateObject("Scripting.FileSystemObject")
ObjFSO.CreateFolder("\\" & strComputer & "\c$\install")
ObjFSO.CreateFolder("\\" & strComputer & "\c$\install\Fonts")
ObjFSO.CopyFile font1, "\\" & strComputer & "\c$\install\Fonts\" & font1file , OverwriteExisting
ObjFSO.CopyFile font2, "\\" & strComputer & "\c$\install\Fonts\" & font2file , OverwriteExisting

Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & _
"\root\cimv2:Win32_Process")
strCommand = "C:\install\Fonts\fontinstall.vbs"
errReturn =  objWMIService.Create(strCommand,null,null,intProcessID)

Loop
 
I run this script copy your script to remote computer and run your script on remote computer.
 

I've updated your script to do a few things.

• Work with Windows 7
• Default to the current folder to look for fonts to install
• Take an alternate font folder as a parameter to find the fonts needed to install

 Option Explicit 
  
 Const FONTS = &H14& 
  
 Const ForAppending = 8 
  
 Dim fso 
 Dim objShell 
 Dim objFontFolder 
 Dim oShell 
 Dim objDictionary 
 Dim strSystemRootDir 
 Dim strFontDir 
 Dim strTempDir 
 Dim f1 
 Dim doExist 
 Dim dontExist 
 Dim yesToAll 
 Dim noProgressDialog 
 Dim noUIIfError 
  
 ' Initialize Global Objects 
  
 Set objShell = CreateObject("Shell.Application") 
  
 Set objFontFolder = objShell.Namespace(FONTS) 
  
 set oShell = CreateObject("WScript.Shell")  
  
 Set fso = CreateObject("Scripting.FileSystemObject") 
  
 Set objDictionary = CreateObject("Scripting.Dictionary") 
  
  
 ' Initialize Global Variables 
 strSystemRootDir = oShell.ExpandEnvironmentStrings("%systemroot%") 
  
 strFontDir = strSystemRootDir & "\fonts\" 
  
 strTempDir = oShell.ExpandEnvironmentStrings("%systemroot%") & "\temp" 
  
 objDictionary.CompareMode = vbTextCompare 
 noProgressDialog = 4 
 yesToAll = 16 
 noUIIfError = 1024 
  
 ' Execute Main Sub-routine 
 Main 
  
 '=================================================================== 
  
 Public Sub Main 
  
 '=================================================================== 
  Dim pwd 
  Dim rootFontInstallFolder 
  Dim param 
   
  Set f1 = FSO.createTextFile(strTempDir & "\installed_fonts.txt", ForAppending) 
  pwd = fso.GetAbsolutePathName(".") 
  
  ' Default to the current folder 
  rootFontInstallFolder = pwd 
  
  If Wscript.Arguments.Count = 1 Then 
  param = Wscript.Arguments(0) 
  If fso.FolderExists(param) Then 
  rootFontInstallFolder = param 
  End If 
  End If 
   
  
  doExist = 0 
  
  dontExist = 0 
  
  
  CollectFonts 
  
  InstallFonts rootFontInstallFolder ' insert path here to font folder 
  
   
  
  wscript.echo doExist & " fonts already installed." & vbcrlf & dontExist & " new fonts installed." 
  
 End Sub 
  
   
  
 '=================================================================== 
  
 Public Sub CollectFonts 
  
 '=================================================================== 
  
  Dim fontFolderPath 
  Dim fontFolder 
  Dim fileName 
  Dim fileExtension 
  Dim filePath 
  Dim oFile 
  Dim firstFileName 
  Dim firstFilePath 
  Dim objItem 
  
  firstFilePath = objFontFolder.Items.Item(0).Path 
  firstFileName = objFontFolder.Items.Item(0).Name 
  fontFolderPath = Replace(firstFilePath, "\" & firstFileName, "") 
  Set fontFolder = fso.GetFolder(fontFolderPath) 
   
  
  For each oFile in fontFolder.Files 
  filePath = oFile.Path 
  fileName = LCase(oFile.Name) 
  fileExtension = LCase(fso.GetExtensionName(filePath)) 
   
  
  If fileExtension = "ttf" or _ 
  
  fileExtension = "otf" or _ 
  
  fileExtension = "pfm" or _ 
  
  fileExtension = "fon" Then 
  
  If Not objDictionary.Exists(fileName) Then 
  
  objDictionary.Add fileName, fileName 
  
  End If 
  
  End If 
  
  Next 
  
  For each objItem in objDictionary 
  
  f1.writeline objDictionary.Item(objItem) 
  
  Next 
  
 End Sub 
  
   
  
 '=================================================================== 
  
 Public Sub InstallFonts(ByVal folder) 
  
 '=================================================================== 
  Dim fontInstallFolder 
  
  Dim fileExtension 
  Dim fileName 
  Dim file 
  Dim subFolder 
   
  Set fontInstallFolder = fso.getFolder(folder) 
   
  
  For Each file in fontInstallFolder.Files 
  
  fileExtension = LCase(fso.GetExtensionName(file)) 
  fileName = LCase(fso.GetFileName(file)) 
   
  
  If fileExtension = "ttf" or _ 
  
  fileExtension = "otf" or _ 
  
  fileExtension = "pfm" or _ 
  
  fileExtension = "fon" Then 
  
  'check if Font is Already installed. If not, Install 
  
  If objDictionary.Exists(fileName) Then 
  
  wscript.echo fileName & " already exists in " & strFontDir 
  
  doExist = doExist + 1 
  
  Else 
  
  'wscript.echo fso.GetAbsolutePathName(File) & " doesn't exists in " & strFontDir 
  
  objFontFolder.CopyHere file.Path, noProgressDialog + yesToAll + noUIIfError 
  
  dontExist = dontExist + 1 
  
  End If     
  
  End If 
  
  Next 
  ' This recurses through subfolders and installs fonts in them 
  
  For Each subFolder in fontInstallFolder.subFolders 
  
  InstallFonts subFolder 
  
  Next 
  
 End Sub
   
   

This is great code and very much appreciated!  Is there a way to not show it installing the fonts?  I want to have it install fonts as users login, but without any message about fonts being installed.
 
Thanks!

Comment out every line that starts:
 
WScript.Echo

I did comment out every WScript.Echo line, but I still get popups.  I'm thinking it might not be from the VB script, but a Windows message about the font being installed.

I think you will always see a Windows message about the font being installed because it's not a vbscript message, it's a Windows message.  I did have some glitchy things happen and I found that with AaronZirbes's code, I needed to change this line...
 
rootFontInstallFolder = pwd

to this...

rootFontInstallFolder = pwd & "\"

Your script works well on windows7-systems.
 
i had to change the line

fontFolderPath = Replace(firstFilePath, "\" & firstFileName, "")

with this line:

fontFolderPath = Left(firstFilePath, InStr(firstFilePath, firstFileName)-2)

to get it working also with windows xp.
Obviously, xp returns the filename with its extension, windows 7 doesn't.