The macro below will display a list of all installed fonts. Note! If you have many fonts installed,
the macro may stop responding because of lack of available memory. If this happens you can try the
sample for Word later in this document.
Sub ShowInstalledFonts()
Const StartRow As Integer = 4
Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As String
Dim fontName As String, i As Long, fontCount As Long, fontSize As Integer
fontSize = 0
fontSize = Application.InputBox("Enter Sample Font Size Between 8 And 30", _
"Select Sample Font Size", 12, , , , , 1)
If fontSize = 0 Then Exit Sub
If fontSize < 8 Then fontSize = 8
If fontSize > 30 Then fontSize = 30
Set FontNamesCtrl = Application.CommandBars("Formatting").FindControl(ID:=1728)
' If Font control is missing, create a temp CommandBar
If FontNamesCtrl Is Nothing Then
Set FontCmdBar = Application.CommandBars.Add("TempFontNamesCtrl", _
msoBarFloating, False, True)
Set FontNamesCtrl = FontCmdBar.Controls.Add(ID:=1728)
End If
Application.ScreenUpdating = False
fontCount = FontNamesCtrl.ListCount
Workbooks.Add
' list font names in column A and font example in column B
For i = 0 To FontNamesCtrl.ListCount - 1
fontName = FontNamesCtrl.List(i + 1)
Application.StatusBar = "Listing font " & _
Format(i / (fontCount - 1), "0 %") & " " & _
fontName & "..."
Cells(i + StartRow, 1).Formula = fontName
With Cells(i + StartRow, 2)
tFormula = "abcdefghijklmnopqrstuvwxyz"
If Application.International(xlCountrySetting) = 47 Then
tFormula = tFormula & "æøå"
End If
tFormula = tFormula & UCase(tFormula)
tFormula = tFormula & "1234567890"
.Formula = tFormula
.Font.Name = fontName
End With
Next i
Application.StatusBar = False
If Not FontCmdBar Is Nothing Then FontCmdBar.Delete
Set FontCmdBar = Nothing
Set FontNamesCtrl = Nothing
' add heading
Columns(1).AutoFit
With Range("A1")
.Formula = "Installed fonts:"
.Font.Bold = True
.Font.Size = 14
End With
With Range("A3")
.Formula = "Font Name:"
.Font.Bold = True
.Font.Size = 12
End With
With Range("B3")
.Formula = "Font Example:"
.Font.Bold = True
.Font.Size = 12
End With
With Range("B" & StartRow & ":B" & _
StartRow + fontCount)
.Font.Size = fontSize
End With
With Range("A" & StartRow & ":B" & _
StartRow + fontCount)
.VerticalAlignment = xlVAlignCenter
End With
Range("A4").Select
ActiveWindow.FreezePanes = True
Range("A2").Select
ActiveWorkbook.Saved = True
End Sub
|
What the IRS Doesn't Want You to Know: A Cpa Reveals the Tricks of the Trade
