modFontInfo.bas

Option Explicit

Private Declare Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" (ByVal hDC As Long, _
                                                                                     lpLogFont As LOGFONT, _
                                                                                     ByVal lpEnumFontProc As Long, _
                                                                                     ByVal lParam As Long, _
                                                                                     ByVal dwReserved As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32" Alias "ReleaseDC" (ByVal hwnd As Long, _
                                                                   ByVal hdc As Long) As Long


Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, _
                                                    ByVal nIndex As Long) As Long

Private Const LF_FACESIZE As Long = 32
Private Const LF_FULLFACESIZE As Long = 64

Private Const ANSI_CHARSET As Long = 0
Private Const DEFAULT_CHARSET As Long = 1

Public Const RASTER_FONTTYPE = &H1        ' raster font
Public Const DEVICE_FONTTYPE = &H2        ' device specific font (depends from hDC)
Public Const TRUETYPE_FONTTYPE = &H4      ' TrueType font

Private Const LOGPIXELSY = 90

Private m_hDC         As Long
Private m_Charset     As Byte
Private m_PitchFamily As Byte
Private m_FaceName    As String

Public Type NEWTEXTMETRIC
  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
  ntmFlags            As Long
  ntmSizeEM           As Long
  ntmCellHeight       As Long
  ntmAveWidth         As Long
End Type

Public Type FONTSIGNATURE
  fsUsb(4)            As Long
  fsCsb(2)            As Long
End Type

Public Type NEWTEXTMETRICEX
  ntmTm               As NEWTEXTMETRIC
  ntmFontSig          As FONTSIGNATURE
End Type

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(0 To (LF_FACESIZE - 1)) As Byte
End Type

Public Type ENUMLOGFONTEX
  elfLogFont          As LOGFONT
  elfFullName(0 To (LF_FULLFACESIZE - 1)) As Byte
  elfStyle(0 To (LF_FACESIZE - 1))        As Byte
  elfScript(0 To (LF_FACESIZE - 1))       As Byte
End Type

Private miSize        As Long     ' font sizes count
Private mlFontInfo    As Long     ' font info count
Private mvaTTsizes    As Variant  ' truetype standard sizes

Public Enum enFontType
  ftRaster = RASTER_FONTTYPE
  ftDevice = DEVICE_FONTTYPE
  ftTrueType = TRUETYPE_FONTTYPE
End Enum


Public Type tagFontInfo
  FontEx    As ENUMLOGFONTEX
  MetricEx  As NEWTEXTMETRICEX
  nType     As enFontType
  sFaceName As String
  sFullName As String
  sStyle    As String
  sScript   As String
  laSizes() As Long
End Type

' font info data
Public taFontInfo()   As tagFontInfo

' convert from byte array to unicode string and trim ending null
Function TrimZ(ByRef cbStr() As Byte) As String
  Dim sStr As String

  sStr = StrConv(cbStr, vbUnicode)
  TrimZ = Left$(sStr, InStr(sStr, vbNullChar) - 1)
End Function

' callback to enumerate sizes
Private Function EnumFontSizesExProc(ByRef lpelfe As ENUMLOGFONTEX, _
                                     ByRef lpntme As NEWTEXTMETRICEX, _
                                     ByVal FontType As Long, _
                                     ByVal lParam As Long) As Long

  Dim lLogSize As Long, lPointSize As Long
  Dim iSize As Long

  If FontType <> TRUETYPE_FONTTYPE Then
    ' if not TT, retrieve available sizes
    lLogSize = lpntme.ntmTm.tmHeight - lpntme.ntmTm.tmInternalLeading
    lPointSize = (lLogSize * 72) / GetDeviceCaps(m_hDC, LOGPIXELSY)
    With taFontInfo(lParam)
      For iSize = LBound(.laSizes) To UBound(.laSizes)
        If .laSizes(iSize) = lPointSize Then
          EnumFontSizesExProc = 1
          Exit Function
        End If
      Next iSize
      ReDim Preserve .laSizes(miSize)
      .laSizes(miSize) = lPointSize
      miSize = miSize + 1
      If miSize = 200 Then
        EnumFontSizesExProc = 0
        Exit Function
      End If
    End With
  Else
    ' for TT fonts use fixed table as a reference
    With taFontInfo(lParam)
      ReDim .laSizes(LBound(malTTsizes) To UBound(malTTsizes))
      For iSize = LBound(malTTsizes) To UBound(malTTsizes)
        .laSizes(iSize) = CLng(mvaTTsizes(iSize))
      Next iSize
    End With
    EnumFontSizesExProc = 0
    Exit Function
  End If

  EnumFontSizesExProc = 1
End Function

' run sizes enumeration for given font
Private Function EnumFontSizes(ByRef lpelfe As ENUMLOGFONTEX, _
                               ByVal lIndex As Long) As Long
  Dim lRet As Long

  ' calls the enumeration for the given font to retrieve sizes
  lRet = EnumFontFamiliesEx(m_hDC, lpelfe.elfLogFont, AddressOf EnumFontSizesExProc, lIndex, 0)
  EnumFontSizes = lRet
End Function

' callback to enumerate fonts
Private Function EnumFontFamiliesExProc(ByRef lpelfe As ENUMLOGFONTEX, _
                                        ByRef lpntme As NEWTEXTMETRICEX, _
                                        ByVal FontType As Long, _
                                        ByVal lParam As Long) As Long
  Dim lIndex As Long
  Dim lRet As Long

  ' add this font to the array
  lIndex = mlFontInfo
  ReDim Preserve taFontInfo(mlFontInfo)
  With taFontInfo(mlFontInfo)
    LSet .FontEx = lpelfe
    LSet .MetricEx = lpntme
    .nType = FontType
    .sFaceName = TrimZ(lpelfe.elfLogFont.lfFaceName)
    .sFullName = TrimZ(lpelfe.elfFullName)
    .sStyle = TrimZ(lpelfe.elfStyle)
    .sScript = TrimZ(lpelfe.elfScript)
    ReDim .laSizes(0)
  End With
  mlFontInfo = mlFontInfo + 1

  ' enumerate available sizes for this font
  miSize = 0
  lRet = EnumFontSizes(lpelfe, lIndex)

  ' continue fonts enumeration
  EnumFontFamiliesExProc = 1
End Function

' load fonts informations
Public Function LoadFonts(Optional ByVal hDC As Long = -1) As Long
  Dim lf As LOGFONT
  Dim lResult As Long

  If hDC = -1 Then
    m_hDC = GetDC(0)
  Else
    m_hDC = hDC
  End If

  ' font enumeration parameters
  m_Charset = DEFAULT_CHARSET
  m_PitchFamily = 0
  m_FaceName = vbNullString

  ' sizes table for TT fonts
  mvaTTsizes = Array(8, 9, 10, 11, 12, 14, 16, 18, 20, 22, 24, 26, 28, 36, 48, 72)

  ' array of font informations
  mlFontInfo = 0
  ReDim taFontInfo(mlFontInfo)

  ' setup parameters
  lf.lfCharSet = m_Charset
  lf.lfPitchAndFamily = m_PitchFamily
  lf.lfFaceName(0) = 0

  ' enumerate fonts
  lResult = EnumFontFamiliesEx(m_hDC, lf, AddressOf EnumFontFamiliesExProc, 0, 0)

  If hDC = -1 Then
    ReleaseDC(0)
  End If

  LoadFonts = lResult
End Function