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).
Download the Excel file with the code
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.
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.
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.
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
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
