Agregar un Label1 y modificar la ruta y el nombre de la Fuente

Código:

Option Explicit

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 FontExist As Boolean
Dim FontTempLoaded As Boolean

Private Sub Form_Load()
 If IsFont("Almanac MT") Then
 FontExist = True
 Else
 Dim lngRet As Long
 lngRet = AddFontResource(App.Path & "\almanac.ttf")
 
 If lngRet > 0 Then
 FontTempLoaded = True
 Else
 Label1.Visible = False
 End If
 End If
 
 'la nueva fuente
 With Label1
 .Font = "Almanac MT"
 .FontBold = True
 .FontSize = 25
 End With

End Sub

Function IsFont(sF As String) As Boolean
 Dim i As Integer
 Screen.MousePointer = vbHourglass
 For i = 0 To Screen.FontCount - 1
 If UCase(sF) = UCase(Screen.Fonts(i)) Then
 IsFont = True
 Exit For
 Else
 IsFont = False
 End If
 Next i
 Screen.MousePointer = vbNormal
End Function

Private Sub Form_Unload(Cancel As Integer)
 Dim lngRet As Long
 If FontTempLoaded Then
 lngRet = RemoveFontResource(App.Path & "\almanac.ttf")
 End If
End Sub

'Private Sub Command1_Click()
'MsgBox IsFont("Almanac MT")
'End Sub

otro ejemplo de como usar una fuente que no esta instalada en el sistema.necesitas un modulo y un label y tambien modifica el nombre de la fuente y la ruta.

En el Modulo:

Option Explicit
Private Declare Function GetTempPath Lib "Kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function AddFontResource Lib "GDI32" Alias "AddFontResourceA" (ByVal FontFileName As String) As Long
Private Declare Function RemoveFontResource Lib "GDI32" Alias "RemoveFontResourceA" (ByVal FontFileName 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

Private Function GetTempPathName() As String
Dim sBuffer As String, lRet As Long
sBuffer = String$(255, vbNullChar)
lRet = GetTempPath(255, sBuffer)
If lRet > 0 Then
sBuffer = Left$(sBuffer, lRet)
End If
GetTempPathName = sBuffer
End Function

Private Function CheckFile(FileName As String) As Boolean 'check if a file exists
On Error GoTo ErrH
CheckFile = False
If Dir(FileName) <> "" Then
If (GetAttr(FileName) And vbDirectory) = 0 Then
CheckFile = True

Kill FileName
Else

Exit Function
End If
Else

Exit Function
End If
ErrH:
End Function

Public Function GetFontName(FileNameTTF As String) As String
Dim hFile As Integer, Buffer As String, FontName As String, TempName As String, iPos As Integer
TempName = GetTempPathName & "tempfntinfo.tmp"
CheckFile (TempName)
If CreateScalableFontResource(0, TempName, FileNameTTF, vbNullString) Then
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

Public Function UseFont(FontFileName As String)
AddFontResource (FontFileName)
UseFont = GetFontName(FontFileName)
End Function

Public Function RemoveFont(FontFileName As String)
RemoveFontResource (FontFileName)
End Function

En el Formulario:

Dim fntFileName01 As String
Dim fntName01 As String

Private Sub Form_Load()
fntFileName01 = App.Path & "\nombredefuente.ttf"
fntName01 = UseFont(fntFileName01)
Label1.Caption = "Canalvisualbasic"
Label1.FontName = fntName01
Label1.FontSize = 16
End Sub

Private Sub Form_Unload(Cancel As Integer)
RemoveFont (fntFileName01)
End Sub

saludos.

Gracias por la información que suben, la verdad que me es de muchísima utilidad para seguir aprendiendo!!

viajes para solas