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