Consulting

Results 1 to 6 of 6

Thread: Macro for showing all fonts

  1. #1
    VBAX Newbie
    Joined
    Oct 2021
    Posts
    5
    Location

    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

  2. #2
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    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

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

  4. #4
    VBAX Newbie
    Joined
    Oct 2021
    Posts
    5
    Location
    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
    Last edited by crazy1; 10-24-2021 at 01:12 AM.

  5. #5
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    arnelgp

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

  6. #6
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •