Fonts and API

[fntzlnd]

Howdy all,

There is all sorts of postings about listing screen/printer fonts installed on your computer using the:

For i = 0 To Printer.FontCount - 1
lvFontList.ListItems.Add(i + 1, , Printer.Fonts(i)) 'populates a listView box...
Next i

... type of syntax.

However, I want to get extended information such as Font Family, the actual font file name, Font Style and where the font lives on the system. Do I need to use an API function? Do I simply loop through the Windows/Font directory and grab file attributes from each file?

What would you do? I appreciate your help. I have come across CreateFont function and EnumFontFamilies function, but I do not know how to use them, let alone use them to populate a list box.

Thanks.

[Hack]

Originally posted by fntzlnd
I want to get extended information such as Font Family, the actual font file name, Font Style and where the font lives on the system.

What do you mean by "Font Family" and "where the font lives on the system"?

[Kaverin]

This will show you how to fill a listbox with some font names using EnumFontFamilies[Ex]. The form you mentioned is kept for compatibility with older forms of windows, but either that or the Ex form is fine. This is a bit lengthy looking, but it really isn't very hard to work with.

'in a module (since the API requires a callback)
Option Explicit
 
Public 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
Public Declare Function SendMessageString Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
 
Public Const LB_ADDSTRING As Long = &H180
Public Const LF_FACESIZE As Long = 32
Public Const LF_FULLFACESIZE As Long = 64
Public Const ANSI_CHARSET As Long = 0
 
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
 
Public Function EnumFontFamiliesExProc(ByRef lpelfe As ENUMLOGFONTEX, ByRef lpntme As NEWTEXTMETRICEX, ByVal FontType As Long, ByVal lParam As Long) As Long
   Dim strFontName As String
   'convert the font name into a unicode string
   strFontName = StrConv(lpelfe.elfLogFont.lfFaceName, vbUnicode)
   'trim off the null terminator
   strFontName = Left$(strFontName, InStr(strFontName, vbNullChar) - 1)
   'add the name to the listbox (lParam is the hWnd passed in)
   SendMessageString lParam, LB_ADDSTRING, 0, strFontName
   'return 1 to continue enumeration
   EnumFontFamiliesExProc = 1
End Function
 
'in a form with a listbox (or wherever you want to start filling the listbox
Private Sub Form_Load()
   Dim lf As LOGFONT
   'this will enumerate all fonts in the ANSI character set
   lf.lfCharSet = ANSI_CHARSET
   lf.lfFaceName(0) = 0
   lf.lfPitchAndFamily = 0
   'enumerate the fonts
   EnumFontFamiliesEx Me.hDC, lf, AddressOf EnumFontFamiliesExProc, List1.hWnd, 0
End Sub

I'm not sure about how to actually retrieve what font family a given font resides in, but if you use CreateFont()
or CreateFontIndirect() and only specify the font's name, you may be able to use the API GetObject() on that font handle
again with a LOGFONT struct and then look at the lf.lfPitchAndFamily member. The system should have
changed it to reflect what family the given font name is a part of and what pitch it has. This is a bit roundabout though,
so there could be an easier way I'm just not seeing (I'm prone to doing things the hard way without much thought,
and easily miss the obvious ). I have no clue on how to find out where the font resides though.