Public Function InstallTTFont(strSourcePath As String, strFontFileName As String, Optional bolShowError As Boolean) As Long
Dim sFontDir As String
Dim sFontName As String
Dim sFOTFile As String
Dim sRegKey As String
Dim sWinDir As String

Dim lDisplay As Long
Dim lFileNum As Long
Dim lLastError As Long
Dim lResult As Long
Dim lRetVal As Long
Dim lErrCntr As Long

Dim tSecAtt As SECURITY_ATTRIBUTES

sWinDir = GetWindowsDir
sFontDir = sWinDir & "FONTS\"
sFOTFile = sFontDir & Left(strFontFileName, Len(strFontFileName) - 4) + ".FOT"
tSecAtt.nLength = 0
tSecAtt.lpSecurityDescriptor = 0
tSecAtt.bInheritHandle = 0

'Copy the fontfile to the FONTS folder
If FileIsNewerVersion(strSourcePath, strFontFileName, sFontDir, strFontFileName) Then
'We've got the newer version, so we should install it
lErrCntr = 0
On Error GoTo InUse 'when the file is in use
FileCopy AddDirSep(strSourcePath) & strFontFileName, sFontDir & strFontFileName
On Error GoTo 0

'(Re)Create the resource file for the font
If Dir(sFOTFile) <> "" Then
'Delete the resource file
Kill sFOTFile
End If
lRetVal = CreateScalableFontResource(0, sFOTFile, strFontFileName, sFontDir)
If lRetVal = 0 Then
If bolShowError Then
lLastError = GetLastError()
If lLastError = 80 Then
MsgBox "Font file " & sFontDir & strFontFileName & "already exists."
ElseIf lLastError <> 0 Then
MsgBox "Error " & Str(lLastError)
End If
End If
Exit Function
End If

'Get the font's name from the resource file
sFontName = GetFontName(sFOTFile)

'Add the font to the system font table.
lRetVal = AddFontResource(sFOTFile)
If lRetVal = 0 Then
If bolShowError Then
lLastError = GetLastError()
If lLastError = 87 Then
MsgBox "Incorrect Parameter"
ElseIf lLastError <> 0 Then
MsgBox "Error " & Str(lLastError)
End If
End If
Exit Function
End If

'Make the font persistent across reboots.
If GetWindowsVersion = wvWindowsNT Then
sRegKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts"
Else
sRegKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Fonts"
End If
lRetVal = RegCreateKeyEx(HKEY_LOCAL_MACHINE, sRegKey, 0, "REG_SZ", _
0, KEY_ALL_ACCESS, tSecAtt, lResult, lDisplay)
'Uncomment the following line to display information
'MsgBox "Key handle : " & lResult & vbCrLf & "Key " & IIf(lDisplay = 1, "created.", "opened (already existed)."), vbOKOnly + vbInformation, "Registry"
lRetVal = RegSetValueEx(lResult, sFontName, 0, 1, strFontFileName, Len(strFontFileName))
'Close the key. Don't keep it open longer than necessary.
lRetVal = RegCloseKey(lResult)
'Notify all the other application a new font has been added.
lRetVal = SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0)
If lRetVal = 0 Then
If bolShowError Then
lLastError = GetLastError()
MsgBox "Error " & Str(lLastError)
End If
End If
'Delete the resource file
Kill sFOTFile
'OK to calling sub
InstallTTFont = 1
Else
'OK to calling sub
InstallTTFont = 2
End If
Exit Function

InUse:
lErrCntr = lErrCntr + 1
If lErrCntr = 2 Then
'We still can't copy the file, so the system
'should do it for us while rebooting
Call ReplaceSystemFile(AddDirSep(strSourcePath) & strFontFileName, sFontDir & strFontFileName)
If bolShowError Then
MsgBox "The font you try to install is currently in use." & vbCrLf & _
"Your computer must be rebooted in order to install it...", vbOKOnly + vbExclamation, "Font installation"
End If
'Inform calling sub of necessary reboot
InstallTTFont = 3
Exit Function
End If
'Try to unregister the font, ...
Call UnregisterFont(sFontDir, strFontFileName)
'... kill the file, ...
Kill sFontDir & strFontFileName
'... and retry copying
Resume
End Function
Public Sub ShutdownSystem(eType As eShutDown)
If Not (eType = shtLogOff Or eType = shtForceLogOff) Then
If GetWindowsVersion = wvWindowsNT Then
Call AdjustToken
End If
End If
Call ExitWindowsEx(eType, &HFFFF)
End Sub