VBA – List Fonts – DEVelopers HUT

Back in 2015 I posted my article VBA – Enumerate Fonts which extracted a list of system fonts by automating Word. However, when I worked on my MS Access – Improved HTML demo I decided I didn’t want any such dependencies and developed some code to do without Word as an intermediary and I thought I’d share it.

The Code

Simply copy/paste the following code into a Standard Module and call the GetListFonts() function (which will return an array of all the available system fonts).

Private sFontsList             As String 'String listing all the system fonts

Private Const LF_FACESIZE = 32
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(LF_FACESIZE)   As Byte
End Type

#If VBA7 Then
    Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Declare PtrSafe Function EnumFonts Lib "gdi32" Alias "EnumFontsA" (ByVal hdc As LongPtr, ByVal lpsz As String, ByVal lpFontEnumProc As LongPtr, ByVal lParam As LongPtr) As Long
    Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    'Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
#Else
    Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
    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
    Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    'Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
#End If


#If VBA7 Then
    Private Function EnumFontProc(ByVal lplf As LongPtr, ByVal lptm As LongPtr, ByVal dwType As LongPtr, ByVal lpData As LongPtr) As LongPtr
#Else
    Private Function EnumFontProc(ByVal lplf As Long, ByVal lptm As Long, ByVal dwType As Long, ByVal lpData As Long) As Long
#End If
    Dim LF                    As LOGFONT
    Dim FontName              As String
    Dim lFontCOunter          As Long
    Dim ZeroPos               As Long

    lFontCOunter = lFontCOunter + 1
    Call CopyMemory(LF, ByVal lplf, LenB(LF))
    FontName = StrConv(LF.lfFaceName, vbUnicode)
    ZeroPos = InStr(1, FontName, Chr$(0))
    If ZeroPos > 0 Then FontName = Left$(FontName, ZeroPos - 1)
    '    If lFontCOunter < 50 Then Debug.Print FontName 'used for testing
    '    Debug.Print FontName
    sFontsList = sFontsList & FontName & ";"
    EnumFontProc = 1
End Function

'---------------------------------------------------------------------------------------
' Procedure : GetListFonts
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Get an array of the system fonts order alphabetically
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Late Binding  -> none required
' References:
'
' Usage:
' ~~~~~~
' aFonts() = GetListFonts()
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' **************************************************************************************
' 1         2021-09-23              Initial Public Release
'---------------------------------------------------------------------------------------
Public Function GetListFonts() As Variant
    On Error GoTo Error_Handler
    Dim aFonts()              As String
    Dim aTempFonts()          As String
    Dim sFonts                As String
    Dim i                     As Long
    Dim j                     As Long

    'Reset the font list if needed
    If sFontsList <> "" Then sFontsList = ""
    'Populate the font list to our string variable
    EnumFonts GetDC(Application.hWndAccessApp), vbNullString, AddressOf EnumFontProc, 0
    'Generate an array from the string
    aTempFonts = Split(sFontsList, ";")
    'Sort the array
    Call QuickSort(aTempFonts, 0, UBound(aTempFonts))
    'Cleanup the font array
    For i = 0 To UBound(aTempFonts)
        If Left(aTempFonts(i), 1) <> "@" And Len(Trim(aTempFonts(i) & "")) > 0 Then
            ReDim Preserve aFonts(j)
            aFonts(j) = aTempFonts(i)
            j = j + 1
        End If
    Next i
    'return the array
    GetListFonts = aFonts

Error_Handler_Exit:
    On Error Resume Next
    sFontsList = ""
    Exit Function

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: GetListFonts" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Helper Function

The above code uses a helper function to sort the array of fonts alphabetically, so you also need to copy/paste the following into a standard module (could be the same module as the font code if you wish).

'Author: Unknown?
'Call QuickSort(myArray, 0, UBound(myArray))
Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
    Dim pivot                 As Variant
    Dim tmpSwap               As Variant
    Dim tmpLow                As Long
    Dim tmpHi                 As Long

    tmpLow = inLow
    tmpHi = inHi

    pivot = vArray((inLow + inHi) \ 2)

    While (tmpLow <= tmpHi)
        While (vArray(tmpLow) < pivot And tmpLow < inHi)
            tmpLow = tmpLow + 1
        Wend

        While (pivot < vArray(tmpHi) And tmpHi > inLow)
            tmpHi = tmpHi - 1
        Wend

        If (tmpLow <= tmpHi) Then
            tmpSwap = vArray(tmpLow)
            vArray(tmpLow) = vArray(tmpHi)
            vArray(tmpHi) = tmpSwap
            tmpLow = tmpLow + 1
            tmpHi = tmpHi - 1
        End If
    Wend

    If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
    If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

Usage Example

You can use the above by doing something like:

Public Sub Test_ListFonts()
'Output the list of fonts to the VBA immediate window
    Dim aFonts()              As String
    Dim vFont                 As Variant
    Dim i                     As Long

    aFonts() = GetListFonts()
    For Each vFont In aFonts
        i = i + 1
        Debug.Print i, vFont
    Next vFont
End Sub

Lastly, another great thing about this code is it is application independent so you can use it in Access, Excel, Outlook, PowerPoint, Word, ... (any VBA environment), is bitness independent (works with both 32 and 64-bit installations).

Windows Handle (Hwnd)

Do note that one modification is required depending in which application you are running the code in. The line:

EnumFonts GetDC(Application.hWndAccessApp), vbNullString, AddressOf EnumFontProc, 0

will need to have the hwnd source changed accordingly. Thus, for:

Access => Application.hWndAccessApp
Excel => Application.hwnd
Publisher => Application.ActiveWindow.hWnd
Word => Application.ActiveWindow.hwnd

So on and so forth.

Download a Demo Database

Feel free to download a 100% unlocked copy by using the link provided below:

Download “VBA - Get List of System Fonts” Fonts.zip – Downloaded 9177 times – 66.99 KB

This demo includes a sample Access database, as well as an Excel Workbook.

Disclaimer/Notes:

If you do not have Microsoft Access, simply download and install the freely available runtime version (this permits running MS Access databases, but not modifying their design):

Microsoft Access 2010 Runtime
Microsoft Access 2013 Runtime
Microsoft Access 2016 Runtime
Microsoft 365 Access Runtime

All code samples, download samples, links, ... on this site are provided 'AS IS'.

In no event will Devhut.net or CARDA Consultants Inc. be liable to the client/end-user or any third party for any damages, including any lost profits, lost savings or other incidental, consequential or special damages arising out of the operation of or inability to operate the software which CARDA Consultants Inc. has provided, even if CARDA Consultants Inc. has been advised of the possibility of such damages.

A Few Resources on the Subject

Page History

Date	Summary of Changes
2021-09-23	Initial Release
2022-12-07	Made 64-bit compatible Added demo/download

blazingAryan July 26, 2022 at 11:20 pm

Hey, looks like the issue is that the WinAPI function, ‘GetDC()’, isn’t defined in the code above. You can either grab the appropriate (will be the bottom one if you’re running 32-bit Office and the versions he listed worked) ‘GetDC’ function from below and privately declare it in your module, OR you can do what I do and just stuff all your WinAPI declarations in their own module and declare them publicly. If you want to do the latter, just ⅰ) copy everything between the dashed lines below, ⅱ) paste it into a new module, and ⅲ) delete the two WinAPI functions he declared from the module where you put his code (both are included in the declaration below). Also, the code I have below checks which version your running before declaring, so it will work in either case if you use the independent WinAPI module method I suggested (or add the same to his code).

————————————————————————————————————————
Option Explicit
#If VBA7 Then ‘ _
§ § Use for mFontList Module
Public Declare PtrSafe Function EnumFonts Lib “gdi32” Alias “EnumFontsA” ( _
ByVal hDC As LongPtr, _
ByVal lpsz As String, _
ByVal lpFontEnumProc As LongPtr, _
ByVal lParam As LongPtr _
) As Long
Public Declare PtrSafe Sub CopyMemory Lib “kernel32” Alias “RtlMoveMemory” ( _
Destination As Any, _
Source As Any, _
ByVal Length As LongPtr _
)
Public Declare PtrSafe Function GetDC Lib “user32” ( _
ByVal hwnd As LongPtr _
) As LongPtr
#Else ‘ _
§ Use for mFontList Module
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 Sub CopyMemory Lib “kernel32” Alias “RtlMoveMemory” ( _
pDst As Any, _
pSrc As Any, _
ByVal ByteLen As Long _
)
Public Declare Function GetDC Lib “user32” Alias “GetDC” ( _
ByVal hwnd As Long _
) As Long
#End If
————————————————————————————————————————

3 responses on “VBA – List Fonts”

Meir January 23, 2022 at 6:11 am

Thanks this is something i’ve been looking for for awhile. I copied to access but on running i get an error on line
EnumFonts GetDC(Application.hWndAccessApp), vbNullString, AddressOf EnumFontProc, 0

sub or function not defined ?

Would appreciate your input on that 🙂

Thanks hoping to hear from you ASAP

Regards
1. Daniel Pineault Post authorJanuary 23, 2022 at 8:22 am
  
  Did you copy the API declarations…? Only thing I can think of. And, since they’re declared as Private they need to be in the same module as the function.
  
  You may also like to look over Get a List of Fonts using VBA and PowerShell for an alternate approach.
2. blazingAryan July 26, 2022 at 11:20 pm
  
  Hey, looks like the issue is that the WinAPI function, ‘GetDC()’, isn’t defined in the code above. You can either grab the appropriate (will be the bottom one if you’re running 32-bit Office and the versions he listed worked) ‘GetDC’ function from below and privately declare it in your module, OR you can do what I do and just stuff all your WinAPI declarations in their own module and declare them publicly. If you want to do the latter, just ⅰ) copy everything between the dashed lines below, ⅱ) paste it into a new module, and ⅲ) delete the two WinAPI functions he declared from the module where you put his code (both are included in the declaration below). Also, the code I have below checks which version your running before declaring, so it will work in either case if you use the independent WinAPI module method I suggested (or add the same to his code).
  
  ————————————————————————————————————————
  Option Explicit
  #If VBA7 Then ‘ _
  § § Use for mFontList Module
  Public Declare PtrSafe Function EnumFonts Lib “gdi32” Alias “EnumFontsA” ( _
  ByVal hDC As LongPtr, _
  ByVal lpsz As String, _
  ByVal lpFontEnumProc As LongPtr, _
  ByVal lParam As LongPtr _
  ) As Long
  Public Declare PtrSafe Sub CopyMemory Lib “kernel32” Alias “RtlMoveMemory” ( _
  Destination As Any, _
  Source As Any, _
  ByVal Length As LongPtr _
  )
  Public Declare PtrSafe Function GetDC Lib “user32” ( _
  ByVal hwnd As LongPtr _
  ) As LongPtr
  #Else ‘ _
  § Use for mFontList Module
  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 Sub CopyMemory Lib “kernel32” Alias “RtlMoveMemory” ( _
  pDst As Any, _
  pSrc As Any, _
  ByVal ByteLen As Long _
  )
  Public Declare Function GetDC Lib “user32” Alias “GetDC” ( _
  ByVal hwnd As Long _
  ) As Long
  #End If
  ————————————————————————————————————————