This should show you most of your fixed width fonts (not necessarily all and
not sure why not)
In a normal module and run GetFixedFonts on a new sheet
Option Explicit
'Private Const LF_FULLFACESIZE As Long = 64
'Private Const FF_ROMAN As Long = 16
'Private Const FF_SWISS As Long = 32
'Private Const FF_MODERN As Long = 48
'Private Const FF_SCRIPT As Long = 64
Private Const ANSI_CHARSET = 0
'private Const DEFAULT_CHARSET = 1
Private Const LF_FACESIZE = 32
Private Const TMPF_FIXED_PITCH As Long = &H1
Private 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
Private Type FONTSIGNATURE
fsUsb(4) As Long
fsCsb(2) As Long
End Type
Private 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
Private Type NEWTEXTMETRICEX
ntmTm As NEWTEXTMETRIC
ntmFontSig As FONTSIGNATURE
End Type
Private Declare Function EnumFontFamiliesEx Lib "gdi32" _
Alias "EnumFontFamiliesExA" ( _
ByVal hDC As Long, ByRef lpLogFont As LOGFONT, _
ByVal lpEnumFontProc As Long, _
ByVal LParam As Long, ByVal dw As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" ( _
ByVal hDC As Long) As Long
Private Declare Function GetDC Lib "user32.dll" ( _
ByVal hWnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32.dll" _
Alias "FindWindowExA" ( _
ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private mcFixed As Collection ', mcVar As Collection
Private Function EnumFontFamExProc(ByRef tLF As LOGFONT, _
ByRef tNTM As NEWTEXTMETRICEX, _
ByVal FontType As Long, ByRef LParam As Long) As Long
Dim sFontName As String
sFontName = StrConv(tLF.lfFaceName, vbUnicode)
sFontName = Left$(sFontName, InStr(sFontName & Chr$(0), Chr$(0)) - 1)
If (tLF.lfPitchAndFamily And TMPF_FIXED_PITCH) = TMPF_FIXED_PITCH Then
mcFixed.Add sFontName
'Elseif etc others
End If
EnumFontFamExProc = 1
End Function
Sub GetFixedFonts()
Dim hWndApp As Long, hWndXL7 As Long, hDC As Long
Dim i As Long
Dim sample As String
Dim tLgFnt As LOGFONT
Set mcFixed = New Collection
If Val(Application.Version) > 9 Then
hWndApp = Application.hWnd
Else
hWndApp = FindWindow("XLMAIN", Application.Caption)
End If
hWndXL7 = FindWindowEx( _
FindWindowEx(hWndApp, 0, "XLDESK", vbNullString), _
0&, "EXCEL7", vbNullString)
hDC = GetDC(hWndXL7)
EnumFontFamiliesEx hDC, tLgFnt, AddressOf EnumFontFamExProc, ByVal 0&, 0
DeleteDC hDC
sample = "My Sample Text"
' or
sample = alphabet
For i = 1 To mcFixed.Count
Cells(i, 1) = mcFixed.Item(i)
With Cells(i, 2)
.Font.Name = mcFixed.Item(i)
.Value = sample
End With
Next
Range("A:B").EntireColumn.AutoFit
Set mcFixed = Nothing
End Sub
Function alphabet() As String
Dim i As Long
Dim s As String
For i = 65 To 65 + 25
s = s & Chr(i)
Next
alphabet = LCase(s) & s
End Function
Regards,
Peter T
