Solved EnumFonts across multiple Office versions (O2013 vs M365 / 32-bit vs 64-bit) (1 Viewer)

[AOB]

Hi there,

I have a module which I use to pull the local system font information into a local table (literally just the available font names) which I've done via EnumFonts as follows :

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
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
....
Public Function GetAvailableFonts() As Boolean
    On Error GoTo ErrorHandler
    Dim dbs As Database
    Set dbs = CurrentDb
    dbs.Execute "DELETE * FROM tblFonts", dbFailOnError
    EnumFonts GetDC(Application.hWndAccessApp), vbNullString, AddressOf EnumFontProc, 0
    GetAvailableFonts = True
   
Exit_GetAvailableFonts:
    On Error Resume Next
    Set dbs = Nothing
    Exit Function

ErrorHandler:
    GetAvailableFonts = False
    Call LogError(Err.Number, Err.Description, "GetAvailableFonts", "modFontFunctions", , False)
    Resume Exit_GetAvailableFonts
   
End Function

Private Function EnumFontProc(ByVal lplf As Long, ByVal lptm As Long, ByVal dwType As Long, ByVal lpData As Long) As Long
    On Error GoTo ErrorHandler
    Dim dbs As Database
    Dim recAvailableFonts As Object
    Dim strSQL As String
    Dim LF As LOGFONT
    Dim FontName As String
    Dim ZeroPos As Long
   
    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)
   
    Set dbs = CurrentDb
    strSQL = "SELECT F.FontName " & _
                "FROM tblFonts F " & _
                "WHERE F.FontName = " & Chr(34) & FontName & Chr(34)
    Set recAvailableFonts = dbs.OpenRecordset(strSQL)
   
    With recAvailableFonts
        If (.BOF And .EOF) Then
            .AddNew
            .Fields("FontName").Value = FontName
            .Update
        End If
    End With
   
    EnumFontProc = 1

Exit_EnumFontProc:
    On Error Resume Next
    recAvailableFonts.Close
    Set recAvailableFonts = Nothing
    Set dbs = Nothing
    Exit Function

ErrorHandler:
    Call LogError(Err.Number, Err.Description, "EnumFontProc", "modFontFunctions", , False)
    Resume Exit_EnumFontProc
   
End Function

This was developed in Office 2013 many moons ago and I've since moved on to M365, so I have to modify my API declarations to accommodate 64-bit Office.

I figured it would be as simple as this :

#If VBA7 Then

    Declare PtrSafe 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 PtrSafe Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
    Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
   
#Else

    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
    Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

#End If

But the module won't compile as it's throwing a type mismatch compile error at this line :

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

Specifically highlighting AddressOf EnumFontProc

Does anybody know what else I need to change to continue using this code?

 

[isladogs]

You also need to change the handles/pointers from Long to LongPtr.
I believe the following is correct :

#If VBA7 Then
    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
    Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
#Else
    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
    Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
#End If

However if all users are running 2010 or later (whether 32-bit or 64-bit), the VBA7 section is all you need. The #Else section is for A2007 or earlier

 

[AOB]

That's worked a treat, thank you so much! I'd been fiddling with the pointers but needed a steer on which ones were causing the issue!

I would be 99.9% sure everybody is on at least 2010, if not in fact 2013, but I'll keep the old syntax in there just in case as it's easier to keep it and have it redundant than to dump it and discover it causes that one person an issue...

 

[isladogs]

Good thinking. Glad it worked. The first API listed caused me grief a while ago
I recommend downloading the utility I used. It doesn't have all APIs but what it does list always seem correct.
See Windows API Viewer for MS Excel (rondebruin.nl)

 

[arnelgp]

not tested:

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

#If VBA7 Then
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
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As LongPtr)
#Else
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
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
#End If
Public Function GetAvailableFonts() As Boolean
    On Error GoTo ErrorHandler
    Dim dbs As Database
    Set dbs = CurrentDb
    dbs.Execute "DELETE * FROM tblFonts", dbFailOnError
    EnumFonts GetDC(Application.hWndAccessApp), vbNullString, AddressOf EnumFontProc, 0
    GetAvailableFonts = True
  
Exit_GetAvailableFonts:
    On Error Resume Next
    Set dbs = Nothing
    Exit Function

ErrorHandler:
    GetAvailableFonts = False
    Call LogError(Err.Number, Err.Description, "GetAvailableFonts", "modFontFunctions", , False)
    Resume Exit_GetAvailableFonts
  
End Function

Private Function EnumFontProc(ByVal lplf As Long, ByVal lptm As Long, ByVal dwType As Long, ByVal lpData As Long) As Long
    On Error GoTo ErrorHandler
    Dim dbs As Database
    Dim recAvailableFonts As Object
    Dim strSQL As String
    Dim LF As LOGFONT
    Dim FontName As String
    Dim ZeroPos As Long
  
    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)
  
    Set dbs = CurrentDb
    strSQL = "SELECT F.FontName " & _
                "FROM tblFonts F " & _
                "WHERE F.FontName = " & Chr(34) & FontName & Chr(34)
    Set recAvailableFonts = dbs.OpenRecordset(strSQL)
  
    With recAvailableFonts
        If (.BOF And .EOF) Then
            .AddNew
            .Fields("FontName").Value = FontName
            .Update
        End If
    End With
  
    EnumFontProc = 1

Exit_EnumFontProc:
    On Error Resume Next
    recAvailableFonts.Close
    Set recAvailableFonts = Nothing
    Set dbs = Nothing
    Exit Function

ErrorHandler:
    Call LogError(Err.Number, Err.Description, "EnumFontProc", "modFontFunctions", , False)
    Resume Exit_EnumFontProc
  
End Function