API for fonts

[ByzantianX]

I've got a userform in MS Word template and I'd like to put a combo box which will be populated by all the fonts from the Fonts directory. Is there some API function which could be helpful for this purpose? Thanks in advance!

 

[strongm]

Here's a VB6 example containing two function, each of which that returns an array containing the list of fonts. The first, ListFonts, is the 'old' way of doing it for compatibility with 16-bit systems. The second, ListFontsEx, is the variant that MS advise be used. The code has to be placed in a code module, rather than a form or class:
[tt]
Option Explicit

Public Declare Function EnumFonts Lib "gdi32" Alias "EnumFontsA" (ByVal hdc As Long, ByVal lpsz As String, ByVal lpFontEnumProc As Long, ByVal lParam As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long


Public Const DEFAULT_CHARSET = 1
Public Const ANSI_CHARSET = 0
Public Const SYMBOL_CHARSET = 2

Public Const OEM_CHARSET = 255

Public Declare Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" (ByVal hdc As Long, lpLogFont As LOGFONT, ByVal lpEnumFontProc As Long, ByVal lParam As Long, ByVal dw As Long) As Long

Public Const LF_FACESIZE = 32

Public FontList() As String
Public FontCount As Long

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

Public Const LF_FULLFACESIZE = 64

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 ENUMLOGFONTEX
elfLogFont As LOGFONT
elfFullName(LF_FULLFACESIZE) As Byte
elfStyle(LF_FACESIZE) As Byte
elfScript(LF_FACESIZE) As Byte
End Type

Public Type NEWTEXTMETRICEX
ntmTm As NEWTEXTMETRIC
ntmFontSig As FONTSIGNATURE
End Type


Public Function EnumFontsProc(ByRef lplf As LOGFONT, ByRef lptm As TEXTMETRIC, dwType As Long, lpData As Long) As Long
Dim strFaceName As String

strFaceName = StrConv(lplf.lfFaceName, vbUnicode)
strFaceName = Left(strFaceName, InStr(strFaceName, Chr(0)) - 1)

ReDim Preserve FontList(FontCount)
FontList(FontCount) = strFaceName
FontCount = FontCount + 1
EnumFontsProc = 1 ' Continue enumeration
End Function

' Return string array containing list of fonts
Public Function ListFonts() As String()
Dim result As Long

ReDim FontList(0)
FontCount = 0
result = EnumFonts(GetDC(0&), vbNullString, AddressOf EnumFontsProc, 0&)
ListFonts = FontList
End Function

Public Function EnumFontFamExProc(ByRef lpelfe As ENUMLOGFONTEX, ByRef lpntme As NEWTEXTMETRICEX, ByVal FontType As Long, ByVal lParam As Long) As Long
Dim strFaceName As String

strFaceName = StrConv(lpelfe.elfFullName, vbUnicode)
strFaceName = Left(strFaceName, InStr(strFaceName, Chr(0)) - 1)

' Filter fonts we want to show
If lpelfe.elfLogFont.lfCharSet = ANSI_CHARSET Or lpelfe.elfLogFont.lfCharSet = OEM_CHARSET Or lpelfe.elfLogFont.lfCharSet = SYMBOL_CHARSET Then
ReDim Preserve FontList(FontCount)
FontList(FontCount) = strFaceName
FontCount = FontCount + 1
End If

EnumFontFamExProc = 1
End Function


Public Function ListFontsEx() As String()
Dim result As Long
Dim lf As LOGFONT

lf.lfCharSet = DEFAULT_CHARSET ' Get all fonts
ReDim FontList(0)
FontCount = 0
result = EnumFontFamiliesEx(GetDC(0&), lf, AddressOf EnumFontFamExProc, 0&, 0&)
ListFontsEx = FontList
End Function
[/tt]