Macro for showing all fonts

Older times i had a handy macro for showing all the system fonts system but it was more than 15 years since then and it has been lost in an older broken HDD
It was an a-z sorting
Can some show advise me a related macro?
thank you

Code:

---

Option Explicit


Sub ShowInstalledFonts()
On Error Resume Next
    Const StartRow As Integer = 4
    Dim cbcFontName As CommandBarControl, cbrFontCmd As CommandBar, strFormula As String
    Dim strFontName As String, i As Long, lngFontCount As Long, intFontSize As Integer
 
    intFontSize = 10
 
    If intFontSize = 0 Then Exit Sub
    If intFontSize < 8 Then intFontSize = 8
    If intFontSize > 30 Then intFontSize = 30
 
    Set cbcFontName = Application.CommandBars("Formatting").FindControl(ID:=1728)
    'Create a temp CommandBar if Font control is missing
    If cbcFontName Is Nothing Then
        Set cbrFontCmd = Application.CommandBars.Add("TempFontNamesCtrl", _
            msoBarFloating, False, True)
        Set cbcFontName = cbrFontCmd.Controls.Add(ID:=1728)
    End If
    Application.ScreenUpdating = False
    lngFontCount = cbcFontName.ListCount
    Workbooks.Add
    ' Column A - font names
    ' Column B - font example
    For i = 0 To cbcFontName.ListCount - 1
        strFontName = cbcFontName.List(i + 1)
        Application.StatusBar = "Listing font " & _
            Format(i / (lngFontCount - 1), "0 %") & " " & _
            strFontName & "..."
        Cells(i + StartRow, 1).Formula = strFontName
        With Cells(i + StartRow, 2)
            strFormula = "abcdefghijklmnopqrstuvwxyz"
            If Application.International(xlCountrySetting) = 47 Then
                strFormula = strFormula & "æøå"
            End If
            strFormula = strFormula & UCase(strFormula)
            strFormula = strFormula & "1234567890"
            .Formula = strFormula
            .Font.Name = strFontName
        End With
    Next i
    Application.StatusBar = False
    If Not cbrFontCmd Is Nothing Then cbrFontCmd.Delete
    Set cbrFontCmd = Nothing
    Set cbcFontName = Nothing
    ' Column 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 + lngFontCount)
        .Font.Size = intFontSize
    End With
    With Range("A" & StartRow & ":B" & _
        StartRow + lngFontCount)
        .VerticalAlignment = xlVAlignCenter
    End With
    Range("A4").Select
    ActiveWindow.FreezePanes = True
    Range("A2").Select
    ActiveWorkbook.Saved = True
End Sub

---

Logit, did you write the code in this site: https://www.exceltip.com/general-top...oft-excel.html
if not use attribution.

thank you but the code is not working MY version is 7.14

I finally found this page with two macros that work :
https://exde601e.blogspot.com/2009/1...microsoft.html

arnelgp

I had lost the info where the code example originated from. Thanks for posting the link.

The following will list all the installed fonts.It will take a while to run if you have a lot of fonts.

Code:

---

Sub ListFonts()
'Graham Mayor - https://www.gmayor.com - Last updated - 25 Oct 2021
Const strText As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ-abcdefghijklmnopqrstuvwxyz-0123456789"
Dim arrFonts() As String
Dim lngIndex As Long
Dim lngFont As Long
Dim oRng As Range
Dim oDoc As Document
    Set oDoc = Documents.Add
    oDoc.Range.Text = "Font List"
    oDoc.Range.Style = "Title"
    ReDim arrFonts(Application.FontNames.Count - 1)
    For lngIndex = 0 To Application.FontNames.Count - 1
        arrFonts(lngIndex) = Application.FontNames(lngIndex + 1)
        DoEvents
    Next lngIndex
    WordBasic.SortArray arrFonts, 0
    For lngFont = 0 To UBound(arrFonts)
        ActiveDocument.Range.InsertAfter vbCr & arrFonts(lngFont)
        Set oRng = ActiveDocument.Paragraphs.Last.Range
        oRng.Style = "Heading 1"
        oRng.InsertParagraphAfter
        oRng.Collapse 0
        oRng.Text = strText & vbCr
        oRng.Style = "Normal"
        oRng.Font.Name = arrFonts(lngFont)
        DoEvents
    Next lngFont
lbl_Exit:
    Set oDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

---