Display all installed fonts (Excel)
2000-04-15 Application 1 129
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.
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 + ", 1).Formula = fontName With Cells(i + ", 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" & " & ":B" & " + fontCount) .Font.Size = fontSize End With With Range("A" & " & ":B" & " + fontCount) .VerticalAlignment = xlVAlignCenter End With Range("A4").Select ActiveWindow.FreezePanes = True Range("A2").Select ActiveWorkbook.Saved = True End Sub