Macro for showing all fonts

[crazy1]

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

[Logit]

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

[arnelgp]

Logit, did you write the code in this site: https://www.exceltip.com/general-topics-in-vba/display-all-installed-fonts-excel-using-vba-in-microsoft-excel.html
if not use attribution.

[crazy1]

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/12/view-all-installed-fonts-with-microsoft.html

[Logit]

arnelgp (http://www.vbaexpress.com/forum/member.php?74556-arnelgp)

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

[gmayor]

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

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