Determine if a Font is TrueType

Programs like Word now displays a 'T' next to fonts that are a TrueType font (which basicallt means that the font will display clearly whatever the size). You can easily discover if a font is truetype or not by temporarily creating the font using Windows API, and then querying if it is a TrueType font or not. The code below shows you how

'Module Code
' Only allow declared variables
Option Explicit
' Declare constants
Public Const TMPF_TRUETYPE = &H4
Public Const LF_FACESIZE = 32
' Declare types
Public Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(1 To LF_FACESIZE) As Byte
End Type
Public Type TEXTMETRIC
    tmHeight As Long
    tmAscent As Long
    tmDescent As Long
    tmInternalLeading As Long
    tmExternalLeading As Long
    tmAveCharWidth As Long
    tmMaxCharWidth As Long
    tmWeight As Long
    tmOverhang As Long
    tmDigitizedAspectX As Long
    tmDigitizedAspectY As Long
    tmFirstChar As Byte
    tmLastChar As Byte
    tmDefaultChar As Byte
    tmBreakChar As Byte
    tmItalic As Byte
    tmUnderlined As Byte
    tmStruckOut As Byte
    tmPitchAndFamily As Byte
    tmCharSet As Byte
End Type
' Declare Windows API functions
Public Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long

Public Function IsFontTrueType(sFontName As String) As Boolean
    Dim lf As LOGFONT
    Dim tm As TEXTMETRIC
    Dim oldfont As Long, newfont As Long
    Dim tmpArray() As Byte
    Dim dummy As Long
    Dim i As Integer
    'need to convert font name to byte array...
    tmpArray = StrConv(sFontName & vbNullString, vbFromUnicode)
    For i = 0 To UBound(tmpArray)
        lf.lfFaceName(i + 1) = tmpArray(i)
    Next
    'create the font object
    newfont = CreateFontIndirect(lf)
    'save the current font object and use the new font object
    oldfont = SelectObject(Me.hdc, newfont)
    'get the new font object's info
    dummy = GetTextMetrics(Me.hdc, tm)
    'determine whether new font object is TrueType
    IsFontTrueType = (tm.tmPitchAndFamily And TMPF_TRUETYPE)
    'restore the original font object - !!!THIS IS IMPORTANT!!!
    dummy = SelectObject(Me.hdc, oldfont)
End Function

'Form Code
Option Explicit

Private Sub Form_Load()
    Dim I As Integer ' Declare variable. 
    For I = 0 To Printer.FontCount -1 ' Determine number of fonts. 
        lstFonts.AddItem Printer.Fonts (I) ' Put each font into list box. 
    Next I
End Sub

Private Sub lstFonts_Click() '// occurs when an item is selected
    ' See if the selected font is a truetype
    If IsFontTrueType(lstFonts.Text) = True Then
        lblTrueType.Caption = "This font is a true type font"
    Else
        lblTrueType.Caption = "This font is not a true type font"
    End If
End Sub

You might also like...

Comments

James Crowley James first started this website when learning Visual Basic back in 1999 whilst studying his GCSEs. The site grew steadily over the years while being run as a hobby - to a regular monthly audience ...

Contribute

Why not write for us? Or you could submit an event or a user group in your area. Alternatively just tell us what you think!

Our tools

We've got automatic conversion tools to convert C# to VB.NET, VB.NET to C#. Also you can compress javascript and compress css and generate sql connection strings.

“Memory is like an orgasm. It's a lot better if you don't have to fake it.” - Seymour Cray