Home > Publications & Training > Case Studies > List fonts in an userform
Google
Web This Site

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

 

 

 

 

 

Comments