ERLANDSEN DATA CONSULTING Excel & VBA Tips   Informasjon på norsk / Information in Norwegian

These pages are no longer updated and are only available for archive purposes.

Click here to visit the pages with updated information.

Display all installed fonts (Excel)

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 + 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

 

Document last updated 2000-04-15 12:49:20      Printerfriendly version

 

Erlandsen Data Consulting     http://www.erlandsendata.no/   
Excel & VBA Tips   Copyright ©1999-2017    Ole P. Erlandsen   All rights reserved
E-mail Contact Address