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
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
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
Last edited by crazy1; 10-24-2021 at 01:12 AM.
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.
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