This will be the last, also found but very confusing:
Call fontAdd("MSGothic", "MSGothic")
Private Function fontAdd(vsFontName As String, vsFileName As String) As Boolean
Dim sTmp As String, sSysPath As String
Dim lResult As Long
Const COPY_TO_FONTS_FOLDER = False
#If Win32 Then
sTmp = vsFileName & ".TTF"
If COPY_TO_FONTS_FOLDER Then
lResult = GetSystemFolderPath(Me.hwnd, CSIDL_FONTS, sSysPath)
If (Right$(sSysPath, 1) <> "\") Then sSysPath = sSysPath & "\"
FileCopy AppPath & sTmp, sSysPath & sTmp
fontAdd = lResult
Exit Sub
End If
sTmp = AppPath & sTmp
lResult = CLng(True)
#Else
sSysPath = Space$(MAX_PATH)
sSysPath = Left$(sSysPath, GetSystemDirectory(sSysPath, MAX_PATH)) & "\"
sTmp = sSysPath & vsFileName & ".FOT"
If COPY_TO_FONTS_FOLDER Then
' Create the font resource file:
lResult = CreateScalableFontResource%(0, sTmp, vsFileName & ".TTF", AppPath)
FileCopy AppPath & vsFileName & ".TTF", sSysPath & vsFileName & ".TTF"
Else
lResult = CreateScalableFontResource(0, sTmp, AppPath & vsFileName & ".TTF", 0&)
End If
#End If
If lResult Then
' Add resource to Windows font table:
lResult = AddFontResource(sTmp)
If lResult Then
' Make changes to WIN.INI to reflect new font:
lResult = WriteProfileString("Fonts", vsFontName, sTmp)
If lResult Then
' Let other applications know of the change:
lResult = SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0&)
' Else
' ' Debug.Print "Error"
End If
' Else
' ' Debug.Print "Error"
End If
' Else
' ' Debug.Print "Error"
End If
fontAdd = lResult
End Function
GetSystemFolderPath function is from Common\Tools\VB\Unsupprt\Shelllnk
Comment from Starman Date: 10/26/1999 04:59AM PDT
Sorry, I forgot to replace code: AppPath is source font path.