Getting a Font List to a Combo Box

The other day a reader asked about how to get a font list to a combo box so his users could have a choice to specify. Borrowing shamelessly from John Walkenbach’s Tip 79, this is one way to do it. I use this approach when I take a spreadsheet to a web table and want to specify the font.

Font Sampler Image

From top to bottom, the form has:

  • A label, named lblFontcboOverLabel
  • A label, named lblFontcbo
  • A combo box, named cboFontOther
  • A frame, named Frame1
  • An option button, named btnAllFonts
  • An option button, named btnMonoFonts

This is the code behind the form:

Option Explicit
Private Fface As String, FaceNdx As Long
Private InstalledFonts As String

Public Property Get FontFace() As String
FontFace = FFace
End Property

Private Sub btnMonoFonts_Click()
Call AddFontBox(1)
Me.lblFontcbo = "Monospace Fonts"
End Sub

Private Sub btnAllFonts_Click()
Dim i As Long
Dim TempFonts As Variant

Me.cboFontOther.Clear

TempFonts = Split(InstalledFonts, ",")
For i = LBound(TempFonts) To UBound(TempFonts)
Me.cboFontOther.AddItem TempFonts(i)
Next i
Me.cboFontOther.Text = "Comic Sans MS"
Me.lblFontcbo = "All Fonts"
End Sub

Private Sub cboFontOther_Change()
Me.lblFontcboOverLabel = Me.cboFontOther.Text
Me.lblFontcboOverLabel.Font = Me.cboFontOther.Text
Me.lblFontcboOverLabel.Font.Size = 12
Fface = Me.cboFontOther.Text
End Sub

Private Sub UserForm_Initialize()
Dim FontList As CommandBarControl
Dim Tempbar As CommandBar, i As Long
'http://www.j-walk.com/ss/excel/tips/tip79.htm

Set FontList = Application.CommandBars("Formatting").FindControl(Id:=1728)
If FontList Is Nothing Then
Set Tempbar = Application.CommandBars.Add
Set FontList = Tempbar.Controls.Add(Id:=1728)
End If
Me.cboFontOther.Clear

For i = 1 To FontList.ListCount
If Left$(FontList.List(i), 1) Like "[A-Za-z0-9]" Then
Me.cboFontOther.AddItem FontList.List(i)
InstalledFonts = InstalledFonts & FontList.List(i)
If i <> FontList.ListCount Then InstalledFonts = InstalledFonts & ","
End If
Next i
Me.lblFontcbo = "All Fonts"

Me.cboFontOther.Text = "Impact"

On Error Resume Next
Tempbar.Delete
End Sub

Private Sub AddFontBox(i As Long)
Dim MonoFont As Variant
'etc

Dim TempFont As Variant, TempStr As String, Str1 As String, Str2 As String

MonoFont = "Monaco,Courier New,Courier,Lucida Sans Typewriter," & _
"Lucida Console,Nimbus Mono L,DejaVu Sans Mono,Andale Mono," & _
"Liberation Mono,Consolas,Courier 10 Pitch,FreeMono," & _
"Menlo Bold,Menlo Bold Italic,Menlo Italic,Menlo Regular," & _
"OCR A Extended,Tlwg Typist,TlwgMono,TlwgTypewriter," & _
"Tlwg Typo,Bitstream Vera Sans Mono"

Select Case i
Case 1: TempFont = Split(MonoFont, ",")
'etc
End Select

Me.cboFontOther.Clear

For i = LBound(TempFont) To UBound(TempFont)
Str1 = TempFont(i) & ","
Str2 = "," & TempFont(i)
If InStr(1, InstalledFonts, Str1, vbTextCompare) Or _
InStr(1, InstalledFonts, Str2, vbTextCompare) Then
TempStr = TempStr & TempFont(i)
If i <> UBound(TempFont) Then TempStr = TempStr & ","
End If
Next i
TempFont = Split(TempStr, ",")

For i = LBound(TempFont) To UBound(TempFont)
Me.cboFontOther.AddItem TempFont(i)
Next i

Me.cboFontOther.Text = TempFont(0)
End Sub

It has the “Get Property” at the top. I screen the installed fonts to filter the Asian fonts from my list. Remove the “Like” operator if you need them. I capture the the installed fonts as a global string variable in a comma-delimited list. The list of monospaced fonts came from here, and represents the fonts installed as a minimum on ⅓ of all Windows, Mac, and Unix computers. They’re listed in percentage order irrespective of machine and not by installation count.

As I use the full form, the Over Label lies atop the combo box. But if you want to see more than the font’s name in its own font, modify the combo box change to something like this:

Private Sub cboFontOther_Change()
Me.lblFontcboOverLabel = "Jackdaws love my big sphinx of quartz."
Me.lblFontcboOverLabel.Font = Me.cboFontOther.Text
Me.lblFontcboOverLabel.Font.Size = 12
Fface = Me.cboFontOther.Text
End Sub

…mrt
©¿©¬

Leave a Reply

Your email address will not be published. Required fields are marked *