Open the Font Picker dialog box in ACCESS 365 and Windows 10

Question

Recently I have been all over the internet attempting to find VBA code that will open the Font Dialog in ACCESS. There have been many solutions but unfortunately none have worked and one uses the CopyMemory function which crashes my ACCESS application when it's used. I do use PtrSafe and LongPtr when required. I have been able to use the Color Picker dialog box which is much easier to open.

Does anyone have any VBA code that will do this? I am using Windows 10 and ACCESS (Office) 365. I have tried the one listed below, but it uses the CopyMemory function which crashes ACCESS.

http://www.access.mvps.org/access/api/api0061.htm

Thank you in advance for any help.

Larry

Answer 1

anonymous user

Give this a try - I not tested with x64, but it should work:

--
updated code:

Option Compare Database  
Option Explicit  
  
  
' ******** Code Start ********  
'This code was originally written by Terry Kreft,  
'and modified by Stephen Lebans  
'It is not to be altered or distributed,  
'except as part of an application.  
'You are free to use it in any application,  
'provided the copyright notice is left unchanged.  
'  
' Contact ******@lebans.com  
'  
Private Const GMEM_MOVEABLE = &H2  
Private Const GMEM_ZEROINIT = &H40  
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)  
  
Private Const LF_FACESIZE = 32  
  
Private Const FW_BOLD = 700  
  
Private Declare PtrSafe Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" _  
(pChoosefont As FONTSTRUC) As Long  
  
  
' Logical Font  
Const LF_FULLFACESIZE = 64  
  
  
Const WM_USER = &H400  
  
  
Const CF_SCREENFONTS = &H1  
Const CF_PRINTERFONTS = &H2  
Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)  
Const CF_SHOWHELP = &H4&  
Const CF_ENABLEHOOK = &H8&  
Const CF_ENABLETEMPLATE = &H10&  
Const CF_ENABLETEMPLATEHANDLE = &H20&  
Const CF_INITTOLOGFONTSTRUCT = &H40&  
Const CF_USESTYLE = &H80&  
Const CF_EFFECTS = &H100&  
Const CF_APPLY = &H200&  
Const CF_ANSIONLY = &H400&  
Const CF_SCRIPTSONLY = CF_ANSIONLY  
Const CF_NOVECTORFONTS = &H800&  
Const CF_NOOEMFONTS = CF_NOVECTORFONTS  
Const CF_NOSIMULATIONS = &H1000&  
Const CF_LIMITSIZE = &H2000&  
Const CF_FIXEDPITCHONLY = &H4000&  
Const CF_WYSIWYG = &H8000& '  must also have CF_SCREENFONTS CF_PRINTERFONTS  
Const CF_FORCEFONTEXIST = &H10000  
Const CF_SCALABLEONLY = &H20000  
Const CF_TTONLY = &H40000  
Const CF_NOFACESEL = &H80000  
Const CF_NOSTYLESEL = &H100000  
Const CF_NOSIZESEL = &H200000  
Const CF_SELECTSCRIPT = &H400000  
Const CF_NOSCRIPTSEL = &H800000  
Const CF_NOVERTFONTS = &H1000000  
  
Const SIMULATED_FONTTYPE = &H8000  
Const PRINTER_FONTTYPE = &H4000  
Const SCREEN_FONTTYPE = &H2000  
Const BOLD_FONTTYPE = &H100  
Const ITALIC_FONTTYPE = &H200  
Const REGULAR_FONTTYPE = &H400  
  
Const WM_CHOOSEFONT_GETLOGFONT = (WM_USER + 1)  
Const WM_CHOOSEFONT_SETLOGFONT = (WM_USER + 101)  
Const WM_CHOOSEFONT_SETFLAGS = (WM_USER + 102)  
  
Const LBSELCHSTRING = "commdlg_LBSelChangedNotify"  
Const SHAREVISTRING = "commdlg_ShareViolation"  
Const FILEOKSTRING = "commdlg_FileNameOK"  
Const COLOROKSTRING = "commdlg_ColorOK"  
Const SETRGBSTRING = "commdlg_SetRGBColor"  
Const HELPMSGSTRING = "commdlg_help"  
Const FINDMSGSTRING = "commdlg_FindReplace"  
  
Const CD_LBSELNOITEMS = -1  
Const CD_LBSELCHANGE = 0  
Const CD_LBSELSUB = 1  
Const CD_LBSELADD = 2  
  
Const LOGPIXELSX = 88        '  Logical pixels/inch in X  
Const LOGPIXELSY = 90        '  Logical pixels/inch in Y  
  
Const SIZEPALETTE = 104      '  Number of entries in physical palette  
Const NUMRESERVED = 106      '  Number of reserved entries in palette  
Const COLORRES = 108         '  Actual color resolution  
  
  
Public Type FormFontInfo  
  Name As String  
  Weight As Integer  
  Height As Integer  
  UnderLine As Boolean  
  Italic As Boolean  
  Color As Long  
End Type  
  
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(LF_FACESIZE) As Byte  
End Type  
  
Type FONTSTRUC  
        lStructSize As Long  
        hwndOwner As LongPtr       '  caller's window handle  
        hdc As LongPtr             '  printer DC/IC or NULL  
        lpLogFont As LongPtr       '  ptr. to a LOGFONT struct  
        iPointSize As Long         '  10 * size in points of selected font  
        flags As Long              '  enum. type flags  
        rgbColors As Long          '  returned text color  
        lCustData As LongPtr       '  data passed to hook fn.  
        lpfnHook As LongPtr        '  ptr. to hook function  
        lpTemplateName As String   '  custom template name  
        hInstance As LongPtr       '  instance handle of.EXE that  
                                   '    contains cust. dlg. template  
        lpszStyle As String        '  return the style field here  
                                   '  must be LF_FACESIZE or bigger  
        nFontType As Integer       '  same value reported to the EnumFonts  
                                   '    call back with the extra FONTTYPE_  
                                   '    bits added  
        MISSING_ALIGNMENT As Integer  
        nSizeMin As Long           '  minimum pt size allowed &  
        nSizeMax As Long           '  max pt size allowed if  
                                   '    CF_LIMITSIZE is used  
End Type  
  
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr  
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" _  
  (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr  
    
    
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _  
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As LongPtr)  
  
  
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" _  
  (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long  
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr  
  
  
Private Function MulDiv(In1 As Long, In2 As Long, In3 As Long) As Long  
  Dim lngTemp As Long  
  On Error GoTo MulDiv_err  
  If In3 <> 0 Then  
    lngTemp = In1 * In2  
    lngTemp = lngTemp / In3  
  Else  
    lngTemp = -1  
  End If  
MulDiv_end:  
  MulDiv = lngTemp  
  Exit Function  
MulDiv_err:  
  lngTemp = -1  
  Resume MulDiv_err  
End Function  
Private Function ByteToString(aBytes() As Byte) As String  
  Dim dwBytePoint As Long, dwByteVal As Long, szOut As String  
  dwBytePoint = LBound(aBytes)  
  While dwBytePoint <= UBound(aBytes)  
    dwByteVal = aBytes(dwBytePoint)  
    If dwByteVal = 0 Then  
      ByteToString = szOut  
      Exit Function  
    Else  
      szOut = szOut & Chr$(dwByteVal)  
    End If  
    dwBytePoint = dwBytePoint + 1  
  Wend  
  ByteToString = szOut  
End Function  
  
Private Sub StringToByte(InString As String, ByteArray() As Byte)  
Dim intLbound As Long  
  Dim intUbound As Long  
  Dim intLen As Long  
  Dim intX As Long  
  intLbound = LBound(ByteArray)  
  intUbound = UBound(ByteArray)  
  intLen = LenB(InString)  
  If intLen > intUbound - intLbound Then intLen = intUbound - intLbound  
For intX = 1 To intLen  
ByteArray(intX - 1 + intLbound) = AscB(MidB(InString, intX, 1))  
Next  
End Sub  
  
  
Public Function DialogFont(ByRef f As FormFontInfo) As Boolean  
    
  Dim LF As LOGFONT, FS As FONTSTRUC  
  Dim lLogFontAddress As LongPtr, lMemHandle As LongPtr  
  
  LF.lfWeight = f.Weight  
  LF.lfItalic = f.Italic * -1  
  LF.lfUnderline = f.UnderLine * -1  
  LF.lfHeight = -MulDiv(CLng(f.Height), GetDeviceCaps(GetDC(hWndAccessApp), LOGPIXELSY), 72)  
  Call StringToByte(f.Name, LF.lfFaceName())  
  FS.rgbColors = f.Color  
  FS.lStructSize = LenB(FS)  
  
  lMemHandle = GlobalAlloc(GHND, LenB(LF))  
  If lMemHandle = 0 Then  
    DialogFont = False  
    Exit Function  
  End If  
  
  lLogFontAddress = GlobalLock(lMemHandle)  
  If lLogFontAddress = 0 Then  
    DialogFont = False  
    Exit Function  
  End If  
  
  CopyMemory ByVal lLogFontAddress, LF, LenB(LF)  
  FS.lpLogFont = lLogFontAddress  
  FS.flags = CF_SCREENFONTS Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT  
  If ChooseFont(FS) = 1 Then  
    CopyMemory LF, ByVal lLogFontAddress, LenB(LF)  
    f.Weight = LF.lfWeight  
    f.Italic = CBool(LF.lfItalic)  
    f.UnderLine = CBool(LF.lfUnderline)  
    f.Name = ByteToString(LF.lfFaceName())  
    f.Height = CLng(FS.iPointSize / 10)  
    f.Color = FS.rgbColors  
    DialogFont = True  
  Else  
    DialogFont = False  
  End If  
End Function  
  
Function test_DialogFont(ctl As Control) As Boolean  
    Dim f As FormFontInfo  
    With f  
      .Color = 0  
      .Height = 12  
      .Weight = 700  
      .Italic = False  
      .UnderLine = False  
      .Name = "Arial"  
    End With  
    Call DialogFont(f)  
    With f  
        Debug.Print "Font Name: "; .Name  
        Debug.Print "Font Size: "; .Height  
        Debug.Print "Font Weight: "; .Weight  
        Debug.Print "Font Italics: "; .Italic  
        Debug.Print "Font Underline: "; .UnderLine  
        Debug.Print "Font COlor: "; .Color  
          
        ctl.FontName = .Name  
        ctl.FontSize = .Height  
        ctl.FontWeight = .Weight  
        ctl.FontItalic = .Italic  
        ctl.FontUnderline = .UnderLine  
        ctl = .Name & " - Size:" & .Height  
    End With  
    test_DialogFont = True  
End Function  
' ********* Code End ***********  
  
Sub Test2()  
  
  
 Dim f As FormFontInfo  
    With f  
      .Color = 0  
      .Height = 12  
      .Weight = 700  
      .Italic = False  
      .UnderLine = False  
      .Name = "Arial"  
    End With  
    Call DialogFont(f)  
    With f  
        Debug.Print "Font Name: "; .Name  
        Debug.Print "Font Size: "; .Height  
        Debug.Print "Font Weight: "; .Weight  
        Debug.Print "Font Italics: "; .Italic  
        Debug.Print "Font Underline: "; .UnderLine  
        Debug.Print "Font COlor: "; .Color  
          
  
    End With  
     
End Sub  

So, above runs with x32. There is a small test code stub at the end - so you can cut + paste into a new code module - run that last test sub (put your cursor anywhere in that last code stub and hit F5. So that can quick test without you having to put this in production code.

Regards,

Albert D. Kallal (Access MVP 2003-2017)
Edmonton, Alberta Canada

Answer 2

anonymous user

The last code stub - sub test2 in above.

so, paste in the whole example into a new code module.

(just create a 100% brand new blank database).

then create a blank new code module.

Paste in above - save it.

Do a debug-compile (just be sure your cut + paste was ok).
(do NOT skip this step!!).

Then after all above - in that code module - in the last routine (test2).

Just place your cursor in that routine - hit f5.
This should pop the dialog.

So, this can all be quick tested in the code part - no forms etc. needed here.

So, for testing - keep this out of production code - use a blank new database.

As noted, the API calls need some tweaking - MORE then just ptr safe is required. A number of the API values need to be changed to LongPtr. So the above code is based on your link - but a number of bits and parts have been changed to work with office x64 bit version.

I have a x64 bit version of office in "one" of my VM's - I'll look around for it, and give above a try just to be sure. (I might have missed a LongPtr in above).

Regards,
Albert D. Kallal (Access MVP 2003-2017)
Edmonton, Alberta Canada

Answer 3

anonymous user

Tag “office-itpro” focuses on general issues about Office desktop applications.
Since your issue is more related to VBA code which is out of our scope of support, I would remove the tag.
Thanks for your understanding.

---

If an Answer is helpful, please click "Accept Answer" and upvote it.
Note: Please follow the steps in our documentation to enable e-mail notifications if you want to receive the related email notification for this thread.

Answer 4

Albert:

This is the exact code I have been trying to get to work for a week now. It simply will not invoke the font dialog box and the CopyMemory function completely crashes ACCESS. And I do use PrtSafe and LongPrt where needed so the code compiles properly.

Exactly which line of code is the dialog box opened?

Answer 5

Albert:

I copied into a new database and new module like you advised and it ran but did not trigger the dialog box. I changed any Log to LongPtr and recompiled. No success.

There has to be something else going on here that I don't know about.

Lawrence Ellefson