Uninstall Fonts through VBScript

I had to uninstall Helvetica and FoundersGrotesk fonts from all the machines in our environment. They had been initially been deployed through MSI a few years back when no one bothered to check if the uninstall of that MSI was actually removing the fonts. So now, since those MSI were not uninstalling the fonts from the machine, I decided to write a VBScript to delete those fonts. While I could find scripts to remove the fonts, but none of them actually helped me to remove the fonts.

I wanted a script which will delete any font starting with Helvetica or FoundersGrotesk from Windows\Fonts folder and from Registry to completely remove it.

You can use this script for other fonts, by replacing Helvetica with your font name and then change the length from 9 to the one of your fonts length. I have mentioned this in comments in the script where you need to change it.

This script will work for both 32-bit an 64-bit machines.


'Script to Delete Font
'Created by: Piyush Nasa
'Date: 21-8-2015
const HKEY_LOCAL_MACHINE = &H80000002

Dim strFolder, objFSO, objFolder, oShell, sCurDir,FileName, oFSO
strFolder = "C:\Windows\Fonts"
Set oShell = CreateObject("WScript.Shell")
sCurDir = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, "\") - 1)

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strFolder)

strComputer = "."
Set objShell = Wscript.CreateObject("Wscript.Shell")
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" &_
strComputer & "\root\default:StdRegProv")

Call CleanFolder(objFolder) 'Remove Font Files

'Remove Registries

strKeyPath = "SOFTWARE\Wow6432Node\Microsoft\Windows NT\CurrentVersion\Fonts"

oReg.EnumValues HKEY_LOCAL_MACHINE, strKeyPath,_
 arrValueNames, arrValueTypes

For i=0 To UBound(arrValueNames)
'Change the length and Name in the line below    
    If (Left(arrValueNames(i), 9) = "Helvetica") Then
    'msgbox "Value Name: " & HKEY_LOCAL_MACHINE & "\" & strKeyPath & "\" & arrValueNames(i)
    objShell.RegDelete "HKEY_LOCAL_MACHINE\" & strKeyPath & "\" & arrValueNames(i)
    End If
Next




Sub CleanFolder(ByVal objParent)
  Dim objChild, objFile
Set oFSO = CreateObject("Scripting.FileSystemObject")
  Set oShell = CreateObject("WScript.Shell")
 
  For Each objFile In objParent.Files
   ' Wscript.Echo " " & objFile.Name
   'Change the length and Name in the line below    
    If (Left(objFile.Name, 9) = "helvetica") Then
FileName =objFSO.GetFileName(objFile)
strFile = strFolder & "\" & FileName
      If oFSO.FileExists(strFile) Then
' Delete the file
oFSO.DeleteFile strFile, True
    End If
    End If
  Next
  For Each objChild In objParent.SubFolders
    Call CleanFolder(objChild)
  Next
 
  Set oFSO = Nothing
End Sub