Display Fonts that aren't installed

[Manri]

Hi there,

does anybody have an idea how to display fonts that aren't installed in my system?

[johnpc]

If their not installed how are you going to
see/display them?

[Manri]

Originally posted by johnpc:
If their not installed how are you going to
see/display them?

I found the solution. I call the WinAPI AddFontResource and I am able to use fonts that aren't in the Windows Font directory like shown below (I typed it in quickly so maybe I mistyped something):

Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFileName As String) As Long
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

Sub SomeCommand()
Dim sz As String
sz = "C:\Windows\Desktop\MyFont.ttf"
AddFontResource(sz)
Text1.Font = GetFontName(sz)
RemoveFontResource(sz)
End Sub

Public Function GetFontName(FileNameTTF As String) As String
Dim hFile As Integer
Dim Buffer As String
Dim FontName As String
Dim TempName As String
Dim iPos As Integer

'Build name for new resource file in
'a temporary file, and call the API.
TempName = App.Path & "\~TEMP.FOT"

If CreateScalableFontResource(1, _
TempName, _
FileNameTTF, _
vbNullString) Then
'The name sits behind the text "FONTRES:"
hFile = FreeFile

Open TempName For Binary Access Read As hFile
Buffer = Space(LOF(hFile))
Get hFile, , Buffer
iPos = InStr(Buffer, "FONTRES:") + 8
FontName = Mid(Buffer, iPos, _
InStr(iPos, Buffer, vbNullChar) - iPos)
Close hFile

Kill TempName
End If

GetFontName = FontName
End Function