Show fonts in an userform

The motivation for this tip was to share how to

1)      dynamically add controls to a userform

2)      respond to events for these controls, and

3)      specifically respond to events using a callback procedure that is located in another class module!

Since this may come across as a fairly technical topic, this tip utilizes the above capabilities to provide a functional solution:

1)      list in an userform the names of all available fonts with each name shown using that font,

2)      hover over the option button associated with a font to see a sample of every English keyboard character in that font,

3)      click on the option button to select the font, and, finally,

4)      use this capability to programmatically get the user’s selection, if any.

Figure 1 is an example of the font selector in action.  Each OptionButton shows the name of one available font using the font itself.  At the same time, the control tool tip shows the font name in English (see the Wide Latin tip).  A sample of how every keyboard character will look in that font appears below the font selector frame.

Figure 1

The motivation for this example was a Daily Dose of Excel blog post by Michael (http://www.dailydoseofexcel.com/archives/2012/03/14/getting-a-font-list-to-a-combo-box-2/).  He used a combo box to list the fonts available to Excel leveraging a technique shown in a tip by John Walkenbach (http://www.j-walk.com/ss/excel/tips/tip79.htm).

 

 

The Excel file containing the macros

Download the Excel file with the code

 

 

Design Considerations

To list the names of the available fonts, we will add, at runtime, one option button for each font available on the system.  To respond to the events of these dynamic controls, one cannot use the traditional method of writing event procedures within the userform code module.  The solution is to use a class module that includes a WithEvents variable and connect the dynamic control with this variable.  John Walkenbach demonstrates the basic idea in one of his tips at http://spreadsheetpage.com/index.php/tip/handle_multiple_userform_buttons_with_one_subroutine/.

The event procedures associated with the WithEvents variable will be in the class module containing the variable.  Obviously, this will be a module other than the one containing the userform code.  So, we have to have a way for the event procedures to call back a subroutine in the userform module.  We will use VBA’s CallByName statement.

Finally, since the list of buttons will be fairly large, there has to be a way to scroll through the list.  To support this, we enable the vertical scroll bar in the frame enclosing the buttons and specify a ScrollHeight that encompasses all the option buttons.

 

 

Building the solution

The solution is fairly straightforward with 2 modules, one a class module named clsFormItem and the other a userform named frmSelectFont.  We look at each module in turn.

 

 

The clsFormItem class module

This is the class module that contains the WithEvents optionbutton variable.  It also contains the code to connect the variable to an existing userform option button, two public variables that contain the names of the callback procedures for the Click and the MouseMove events, and the 2 corresponding event procedures. 

An important point to note about clsFormObj is that it is self-contained.  One can drop it into any project and start to use it.  It is also fairly straightforward to adapt it to another type of control requiring only a change in the type of xFormItem.  Similarly, it is trivial to extend to other events, requiring one callback procedure name per event and mimicking the structure of one of the existing event procedures for the new event procedure.

Also, if the code to identify the userform containing the control appears to be a bit convoluted, the comments in the findUF function explain why.

In a class module named clsFormObj:

Option Explicit

 

Dim WithEvents xFormItem As MSForms.OptionButton

Dim UF  ‘if we declare this as a userform the callback won't work!?

Public ClickCallback As String, MouseMoveCallback As String

 

    Function findUF(X As MSForms.Control)

        'This finds the userform containing X.  We cannot directly test _

         typename(...)="Userform" because a userform's typename is the name _

         of the userform, e.g., frmSelectFont or the default of Userform1, _

         Userform2, etc. _

         We cannot test Typeof Y is MSForms.Userform because it incorrectly _

         returns True for a frame! _

         So, we indirectly infer that an object is a userform if it is not _

         any of the others that could contain an embedded control.

        Dim Y

        Set Y = X.Parent

        Do While TypeName(Y) = "Frame" Or TypeName(Y) = "Page" _

                Or TypeName(Y) = "MultiPage"

            Set Y = Y.Parent

            Loop

        Set findUF = Y

        End Function

Property Set FormItem(uFormItem As MSForms.Control)

    Set xFormItem = uFormItem

    Set UF = findUF(uFormItem)

    End Property

Property Get FormItem() As MSForms.Control

    Set FormItem = xFormItem

    End Property

Private Sub xFormItem_Click()

    If ClickCallback <> "" Then _

        CallByName UF, MouseMoveCallback, VbMethod, _

            xFormItem, Button, Shift, X, Y

    End Sub

 

Private Sub xFormItem_MouseMove(ByVal Button As Integer, _

        ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    If MouseMoveCallback <> "" Then _

        CallByName UF, MouseMoveCallback, VbMethod, xFormItem

    End Sub

Next, we look at the userform design and the associated code.

 

 

Building the userform

It will make it that much easier to understand the code if one knew the components of the userform.  The name of the form is frmSelectFont.  It’s components are shown in Figure 2:

Figure 2

Now, that we know the components, we can write the callback routines:

1.      When the user clicks on an option button, we want to identify that font as the selected font and close the userform.

2.      When the user hovers over an option button, we want to change the font of the sample (lblSample) to that of the option button.  Of course, we do this only when the user first moves over a button.  It would serve little purpose to change the font for subsequent mouse movements over the same button.

The code below is part of the userform frmSelectFont code module

Option Explicit

Dim sSelectedFont As String

 

Public Sub SelectedFont(uSelectedFont As MSForms.Control)

    sSelectedFont = uSelectedFont.Caption

    Me.Hide

    End Sub

Public Sub DemoFont(ByVal MouseOverFont As MSForms.Control, _

        ByVal Button As Integer, ByVal Shift As Integer, _

        ByVal X As Single, ByVal Y As Single)

    Static lastCtrl As MSForms.Control

    If lastCtrl Is Nothing Then

    ElseIf lastCtrl.Name = MouseOverFont.Name Then

        Exit Sub

        End If

    Set lastCtrl = MouseOverFont

    With MouseOverFont

    Me.lblSample.Font.Name = .Caption

    Me.lblFontName.Caption = .Caption

        End With

    Me.Repaint: DoEvents

    End Sub

Next, we look at the code to create the option buttons.  This will happen at the time of initializing the userform in the userform’s Initialize event procedure

1.      Get a list of all available fonts in an array by calling the getFontList function, which uses the technique shown by John Walkenbach.

2.      For each font in the array FontList,

a.      creates an option button within Frame1 and connects it to the WithEvents variable of the clsFormItem class

b.      specify the callback routines

c.      position the new option button after the previous button if any,

d.      update the caption, the caption’s font, fontsize, and the ControlTipText,

e.      resize the various controls and containers to show, if possible, the caption of each option button in a single line, and finally,

f.       adjust the ScrollHeight so that the Frame1 scrollbar will include all the option buttons.

In the code module for the userform frmSelectFont:

Option Explicit

Dim AllOptions As Collection

Function getFontList()

   Dim FontList As CommandBarControl

   'http://www.j-walk.com/ss/excel/tips/tip79.htm

    On Error Resume Next

    Set FontList = Application.CommandBars("Formatting") _

        .FindControl(ID:=1728)

    On Error GoTo 0

    If FontList Is Nothing Then

        Dim Tempbar As CommandBar

        Set Tempbar = Application.CommandBars.Add

        Set FontList = Tempbar.Controls.Add(ID:=1728)

        End If

    Dim Arr() As String: ReDim Arr(FontList.ListCount - 1)

    Dim I As Integer

    For I = 0 To UBound(Arr)

        Arr(I) = FontList.List(I + 1)

        Next I

    getFontList = Arr

    On Error Resume Next

    Tempbar.Delete

    End Function

Private Sub UserForm_Initialize()

    Dim FontList() As String: FontList = getFontList()

    Me.Frame1.ScrollBars = fmScrollBarsVertical

    Set AllOptions = New Collection

    Dim I As Integer

    For I = LBound(FontList) To UBound(FontList)

        Dim aCtrl As clsFormObj: Set aCtrl = New clsFormObj

        Set aCtrl.FormItem = Me.Frame1.Controls.Add( _

            "Forms.optionbutton.1", "Option" & I)

        aCtrl.ClickCallback = "SelectedFont"

        aCtrl.MouseMoveCallback = "DemoFont"

        With aCtrl.FormItem

        If I = LBound(FontList) Then

            .Top = 0

        Else

            With .Parent.Controls("Option" & (I - 1))

            aCtrl.FormItem.Top = .Height + .Top

                End With

            End If

        .Font.Name = FontList(I)

        .Caption = FontList(I)

        .ControlTipText = FontList(I)

        .Font.Size = 12

        .Width = .Parent.Parent.Width

        .AutoSize = True: .AutoSize = False

        If .Parent.Width < .Width Then .Parent.Width = .Width

            End With

        AllOptions.Add aCtrl, aCtrl.FormItem.Name

        Next I

    With Me.Frame1

    Dim Ctrl As MSForms.Control

    For Each Ctrl In .Controls

        Ctrl.Width = .Width

        Next Ctrl

        End With

    With aCtrl.FormItem

    Me.Frame1.ScrollHeight = .Top + .Height + 1

        End With

End Sub

A couple of final touches to the userform code:

We have to provide a method in the userform that the developer using the form can call to get the user’s font selection, keeping in mind that the user may make no selection.

Since this userform has no Cancel button, the X in the top right corner will serve as the way to cancel the form without making a selection.  We have to handle this user choice.

In the code module of the userform named frmSelectFont:

Public Function getFontName(ByRef uFontName As String) As Boolean

    Me.Show

    If sSelectedFont <> "" Then _

        getFontName = True: uFontName = sSelectedFont

    End Function

 

Private Sub Cancel_Click()

    sSelectedFont = ""

    Me.Hide

    End Sub

 

Private Sub UserForm_QueryClose(Cancel As Integer, _

        CloseMode As Integer)

    Cancel_Click

    End Sub

 

 

Consuming the solution

We are now ready to use this solution.  Any developer can drop the frmSelectFont and clsFormItem modules into their project and use the frmSelectFont.getFontName method.  As a test, put the below code in a standard module and run the getGoing subroutine.

In a standard module:

Option Explicit

 

Sub getGoing()

    Dim uFontName As String

    If frmSelectFont.getFontName(uFontName) Then _

        MsgBox "Selected font: " & uFontName _

    Else MsgBox "No font selected"

    End Sub