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
