AOB
Registered User.
- Local time
- Today, 07:37
- Joined
- Sep 26, 2012
- Messages
- 615
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 :
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 :
But the module won't compile as it's throwing a type mismatch compile error at this line :
Specifically highlighting AddressOf EnumFontProc
Does anybody know what else I need to change to continue using this code?
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 :
Code:
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 :
Code:
#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 :
Code:
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?