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.
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
©¿©¬
Posting code? Use <pre> tags for VBA and <code> tags for inline.