[Home]  [Edit this page]  [Recent Changes]  [Special Pages]  [Help] 

---

MSAccess-ShowFontDialog

---

How To Implement the Show Font dialog box in code

This module brings up a Show Font dialog box for a rich text box (rtb). It will be initialized to the current font choices of the selected text in the rtb - eg: font color, size, weight (boldness), etc. To implement, create a form with an rtb control and a command button. Insert some text in the rtb, select some or all of the text, and click the button. In the button's click event, put this code:

    Sub cmdShowFont
        ShowFont RichTextBox1    ' the name of the rtb control
    End Sub

Note: This doesn't use any additional references (except for the rich text box).

Here's the Show Font module's code:

Option Compare Database
Option Explicit
Dim ctl As Control
Dim j%
Const LF_FACESIZE = 32
Const CF_SCREENFONTS = 1
Const CF_BOTH = 3
Const CF_EFFECTS = 256        ' &H100
Const CF_INITTOLOGFONTSTRUCT = &H40
Const CF_FORCEFONTEXIST = &H10000
Const CF_LIMITSIZE = &H2000&
Const FW_BOLD = 700
Const FW_NORMAL = 400
Const DEFAULT_CHARSET = 1
Const REGULAR_FONTTYPE = &H400
Const LOGPIXELSY = 90
Const CLSCD_ERRNUMUSRCANCEL = -499  ' create own error codes rmm
Const CLSCD_ERRDESUSRCANCEL = "User cancelled choose font dialog."
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40
Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
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 As String * 32
End Type
Type CHOOSEFONT
    lStructSize As Long
    hwndOwner As Long
    hdc As Long
    lpLogFont As Long
    iPointSize As Long
    flags As Long
    rgbColors As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
    hInstance As Long
    lpszStyle As String
    nFontType As Integer
    MISSING_ALIGNMENT As Integer
    nSizeMin As Long
    nSizeMax As Long
End Type
'API function called by ShowFont method
Private Declare Function ChooseFontA Lib "comdlg32.dll" _
 (pChoosefont As CHOOSEFONT) As Long
'API function to retrieve extended error information
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" _
 () As Long
'API memory functions
Private Declare Function GlobalAlloc Lib "KERNEL32" _
  (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "KERNEL32" _
  (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "KERNEL32" _
  (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "KERNEL32" _
  (ByVal hMem As Long) As Long
Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
  (Destination As Any, Source As Any, ByVal Length As Long)
' Device API's
Declare Function GetDeviceCaps Lib "gdi32" _
  (ByVal hdc As Long, ByVal nIndex As Long) As Long
Declare Function GetDC Lib "user32" _
  (ByVal hwnd As Long) As Long
Public Sub ShowFont(ctl As Control)
'Provide the ShowFont method and interface
'with the Win32 ChooseFont function
Dim lf As LOGFONT
Dim cf As CHOOSEFONT
Dim lLogFontSize As Long
Dim lLogFontAddress As Long
Dim lMemHandle As Long
Dim lReturn As Long
Dim sFont As String
Dim lBytePoint As Long
' rmm add missing vars
Dim bCancelError As Boolean
Dim bFontBold As Boolean
Dim bFontItalic  As Boolean
Dim bFontUnderline As Boolean
Dim GHND&
Dim lFlags&
Dim lApiReturn&, lExtendedError&
Dim fontname$
Dim lFontSize&
Dim lFontColor&
Dim t$              ' temp for msgbox testo
Dim nl              ' vbnewline
nl = vbNewLine      ' rmm
'On Error GoTo ShowFontError
lf.lfCharSet = DEFAULT_CHARSET
lf.lfWeight = FW_NORMAL
' rmm - set dialog values to selection values
lf.lfFaceName = ctl.SelFontName & "" & vbNullChar       ' font name
If ctl.SelBold = True Then                              ' bold
    lf.lfWeight = FW_BOLD
End If
lf.lfItalic = Nz(ctl.SelItalic, 0)                      ' italic
lf.lfUnderline = Nz(ctl.SelUnderline, 0)                ' underline
lFontColor = Nz(ctl.SelColor, 0)                        ' font color
lFontSize& = Nz(ctl.SelFontSize, 0)                     ' font size
lf.lfHeight = lFontSize& * GetDeviceCaps(GetDC(0), LOGPIXELSY) \ 72
lLogFontSize = Len(lf)
lMemHandle = GlobalAlloc(GHND, lLogFontSize)
If lMemHandle Then
    lLogFontAddress = GlobalLock(lMemHandle)
    If lLogFontAddress Then
        
        ' copy structure's contents into block
        CopyMemory ByVal lLogFontAddress, lf, Len(lf)
        
        cf.lStructSize = Len(cf)
        cf.lpLogFont = lLogFontAddress         ' pointer to lf
        cf.nFontType = REGULAR_FONTTYPE
        cf.rgbColors = lFontColor
        cf.flags = CF_BOTH Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT
        lApiReturn = ChooseFontA(cf)    'store to APIReturn property
        
        Select Case lApiReturn
            Case 0  ' = CLSCD_USERCANCELED
                If bCancelError = True Then
                    'Clean up memory first.
                    lReturn = GlobalUnlock(lMemHandle)
                    lReturn = GlobalFree(lMemHandle)
                    'Generate an error...
                    'On Error GoTo 0
                    'Err.Raise Number:=CLSCD_ERRNUMUSRCANCEL, _
                       Description:=CLSCD_ERRDESUSRCANCEL
                    Exit Sub
                End If
            Case 1 ' = CLSCD_USERSELECTED
               ' copy block's contents into structure
                CopyMemory lf, ByVal lLogFontAddress, Len(lf)
                
                lReturn = GlobalUnlock(lMemHandle)
                lReturn = GlobalFree(lMemHandle)
                
                ' rmm - set selection values to dialog values
                ' doesn't work for bookman old style !?!?!?
                ctl.SelBold = (lf.lfWeight >= FW_BOLD)
                ctl.SelItalic = lf.lfItalic
                ctl.SelUnderline = lf.lfUnderline
                ctl.SelFontSize = cf.iPointSize / 10
                ctl.SelColor = cf.rgbColors
                ctl.SelFontName = Left(lf.lfFaceName, _
                 InStr(lf.lfFaceName, vbNullChar) - 1)
                
            Case Else   'An error occurred.
                'Clean up memory first.
                lReturn = GlobalUnlock(lMemHandle)
                lReturn = GlobalFree(lMemHandle)
                'call CommDlgExtendedError if u want to show errors
                ' store to ExtendedError
                lExtendedError = CommDlgExtendedError
        End Select
    Else
        lReturn = GlobalFree(lMemHandle)
        Exit Sub
    End If
End If
Exit Sub
ShowFontError:
'Clean up memory first.
lReturn = GlobalUnlock(lMemHandle)
lReturn = GlobalFree(lMemHandle)
Exit Sub
End Sub

Microsoft Access FAQ
[Edit this page]  [Page history]  [What links here]  [Discuss this topic]  [Printer Friendly]