Binaryworld - How to use font for your application without installing into the syste ... [ VB -> Font ]

Windows application use only those fonts which are registered into the registry and copied to the Fonts directory. But what if you have to use font for your application which is not installed yet.

This code will show you how you can add font entry in to windows font table which is just temperory entry.

To run this demo
-> Create standard exe project
-> Add one Label control, textbox and command button on the form

Click here to copy the following block

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
Dim AppPath As String
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

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

'Return the font name
GetFontName = FontName
End Function

Private Sub Command1_Click()
  'Add the font to the Windows Font Table
  AddFontResource Text1
  'Write something on the form
  Label1 = GetFontName(Text1)
  Me.AutoRedraw = True
  Me.FontName = lblName
  Me.FontSize = 15
  Me.FontBold = True
  Me.CurrentX = 1000
  Me.CurrentY = Me.Height / 2 - 1000

  Me.Print Label1 & " font demo"
End Sub

Private Sub Form_Load()
  AppPath = App.Path
  If Right$(AppPath, 1) <> "\" Then AppPath = AppPath + "\"
  '//Some free fonts available at http://www.1001freefonts.com/winfonts/
  txtFontPath = AppPath + "abduction2002.ttf"
End Sub
Private Sub Form_Unload(Cancel As Integer)
  'Remove the font from the Windows Font Table
  ret = RemoveFontResource(txtFontPath)
End Sub