Previously, I wrote a bit about fonts that won’t install under Vista (and possibly Windows XP SP2, but I haven’t tested that).

Apparently, Vista expects certain fields within the TTF file to be filled, whereas older versions of Windows don’t. The result is that while you might have been able to install a particular TTF file perfectly fine under an older version of Windows, the same font won’t install under Vista, with Vista claiming the font is corrupted.

Enter Font Creator Pro 5.6, a utility to actually allow you to edit fonts. One of its ancillary features, however, is the ability to correct this problem in TTF files quite easily.

Unfortunately, it’s a very manual process, requiring a lot of mousing or keyboarding.

Until now!

I cobbled up a short little VBScript that will accept either dragging and dropping onto it, either:

• a single TTF file
• Several TTF files
• or a single folder containing a bunch of TTF files

The script essentially automates the process of loading the font into Font Creator, applying the rename fix and saving the font out.

Note that it saves the font in place (for simplicity’s sake more than anything else), which means that you should make a backup of any font you process with this.

'FONT FIX SCRIPT
'Darin Higgins May 2009
'---------------------------------------------
'Requirements
'------------
'Eval or licensed copy of Font Creator 5.6
'
'Purpose
'-------
'Many Fonts will not install properly under Windows XP SP2 or Vista, because they are 
'missing a few values for several internal fields.
'While the field values themselves are immaterial, Windows will consider the font "corrupt"
'
'What this script does
'------------
'You can drag either a single TTF font file or a folder that contains a number of TTF files
'onto this script.
'The script will run and will use Font Creator to
'1) Open the font
'2) Perform a Font Creator "AutoName" on the font
'3) Close and save the font, overwriting the original file.
'
'I've never had problems but if you are concerned, be sure to make a backup copy of
'all your font files first.
'
'Usage
'-----
'1) Make sure that you've opened Font Creator, clicked past the eval screen
'   and have an empty window open before running this script
'2) Drag iether a single TTF file or a folder containing TTF files onto this script
'3) The script should run, with lots of window flashing.
'4) Don't touch anything, even if you hear beeps.
'5) Eventually the script will finish. It is possible that some files didn't get saved properly
'   so check each file with a good font viewer app.
'
'--------------------------------------------------

dim Name
Dim fso, fldr, s, file
dim shell
Dim Count, x
dim excel

Set shell = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
set Excel = nothing

for x = 0 to wscript.arguments.count-1
    Name = wscript.arguments(x)
    on error resume next
    '---- first, try to retrieve argument as a file
    if fso.FileExists(name) then
        '---- it worked, convert the single file
        Count = Count + 1
        CheckForQuit
        FixTheFont name
        CheckForQuit

    elseif fso.FolderExists(name) then
        '---- try to get a folder
        on error resume next
        Set fldr = fso.GetFolder(Name)    
        For each file in fldr.files
            if instr(1,ucase(File.Name),".TTF") <> 0 then
                Count = Count + 1
                CheckForQuit
                FixTheFont File.Path
                CheckForQuit
            end if
        next
    end if
next

'---- don't show a message if Only one file was processed
if Count > 1 then Msgbox "All Done"

'---- Alert if nothing was processed
if Count = 0 then Msgbox "No fonts were processed"

CleanUp

'====================================================
'End of main script
'====================================================

Sub CleanUp()
    if not Excel is nothing then excel.quit
    wscript.quit(1)
End Sub



'---- this subroutine uses sendkeys to 
'1) load the font in FontCreator 
'2) tell FC to perform the AUTONAME function on the loaded font
'3) close and save the font
Sub FixTheFont(File)
    shell.appactivate "FontCreator 5.6 (UNREGISTERED)"

    wscript.sleep 1000
    shell.sendkeys "%F{DOWN}{RIGHT}{DOWN}{ENTER}" 
    wscript.sleep 500

    '---- fix up possible bad elements in the Filename (could conflict with SendKeys)
    File = Replace(File, "{", chr(1) & "1")
    File = Replace(File, "}", chr(1) & "2")
    File = Replace(File, "(", chr(1) & "3")
    File = Replace(File, ")", chr(1) & "4")
    File = Replace(File, "[", chr(1) & "5")
    File = Replace(File, "]", chr(1) & "6")
    File = Replace(File, "+", chr(1) & "7")
    File = Replace(File, "~", chr(1) & "8")
    File = Replace(File, "%", chr(1) & "9")
    File = Replace(File, "^", chr(1) & "A")

    File = Replace(File, chr(1) & "1", "{{}")
    File = Replace(File, chr(1) & "2", "{}}")
    File = Replace(File, chr(1) & "3", "{(}")
    File = Replace(File, chr(1) & "4", "{)}")
    File = Replace(File, chr(1) & "5", "{[}")
    File = Replace(File, chr(1) & "6", "{]}")
    File = Replace(File, chr(1) & "7", "{+}")
    File = Replace(File, chr(1) & "8", "{~}")
    File = Replace(File, chr(1) & "9", "{%}")
    File = Replace(File, chr(1) & "A", "{^}")

    shell.sendkeys file & "{ENTER}"
    wscript.sleep 500

    Shell.SendKeys "%LN"
    wscript.sleep 500
    shell.sendkeys "{ENTER}{ENTER}"
    wscript.sleep 500
    shell.sendkeys "%FC{ENTER}"
    wscript.sleep 1500
end sub


'------------------------------------
'Check to see if user pressed esc
'Do this using a hadny little hack through excel
'There's likely better ways, but this works
'------------------------------------
dim Skip
Sub CheckForQuit
    if Skip = true then exit sub

    On Error Resume Next
    '---- make sure Excel exists and we can create an object
        '     if not, no big deal, just skip all this code
    if excel is nothing then
         set excel = CreateObject("Excel.Application")
                if err then Skip = true
        end if

    if Skip = true then exit sub

    dim keys(0)
    'ESCAPE
    keys(0) = 27

    dim Passed
    Passed = 1
    For i = 0 To UBound(keys)
        keystate = excel.ExecuteExcel4Macro("CALL(""user32"",""GetAsyncKeyState"",""JJ""," & keys(i) & ")")
        If (keystate and 1) = 0 Then
            Passed = 0
        End If
    Next

    If Passed = 1 Then
        CleanUp
    End If
End Sub

To use it, just copy the text above and save it to a FixFont.VBS file on your desktop.

Then, back up a font TTF file you want to process, and simply drag it from Explorer onto the VBS script.

Then sit back and let it drive for a few seconds.

Each font takes about 2-3 second to fix.

It doesn’t work 100% (sometimes the SENDKEYS just don’t get synchronized properly), but I didn’t have any problems as a result, and I processed some 10,000 fonts through it. It just took several passes (and a few days<g>)

One final note. I used a trick from Excel to check if the ESCAPE key has been pressed and terminate the script. If you have Excel, that should work fine. If not, it should just skip all that, but that means you won’t be able to stop the script should you need to. To be safe, just do a few fonts at a time.

And as with everything else here, IWOMM (It Works On My Machine) but your mileage may vary.