Option Explicit

Private Const HWND_BROADCAST = &HFFFF&
Private Const WM_FONTCHANGE = &H1D

Private Declare Function CreateScalableFontResource Lib "gdi32" Alias
"CreateScalableFontResourceA" (ByVal fHidden As Long, ByVal lpszResourceFile As
String, ByVal lpszFontFile As String, ByVal lpszCurrentPath As String) As Long

Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal
lpFileName As String) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As
Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Sub InstallFont(ByVal sTTFFile As String)
    Dim iExt As Integer
    Dim iBackslash As Integer
    Dim sDestPath As String
    Dim sFileName As String
    Dim sFOTFile As String
    Dim sSrcPath As String

    ' Find last backslash in TTF file name
    iBackslash = InStrRev(sTTFFile, "\")
    If iBackslash Then
        ' Exract path and file name
        sSrcPath = Left$(sTTFFile, iBackslash)
        sFileName = Mid$(sTTFFile, iBackslash + 1)
    Else
        ' If no backslash, assume file is
        ' in current directory
        sSrcPath = CurDir$
        sFileName = sTTFFile
    End If

    ' Find .TTF file extension
    iExt = InStr(sFileName, ".ttf")
    ' Generate .FOT file name
    If iExt Then
        sFOTFile = Left$(sFileName, iExt - 1) & ".fot"
    Else
        sFOTFile = sFileName & ".fot"
    End If

    ' Optional: Copy TTF file to font folder
    sDestPath = GetFontFolder()
    FileCopy sTTFFile, sDestPath & sFileName

    ' Call CreateScalableFontResource
    ' to create .FOT file
    Call CreateScalableFontResource(0, sFOTFile, sFileName, sDestPath)

    ' Call AddFontResource to install font
    Call AddFontResource(sFOTFile)

    ' Call SendMessage to notify other apps
    ' that font has been added
    Call SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0)

    ' Delete font resource file
    Kill sDestPath & sFOTFile
End Sub