Display all installed fonts (Word)
2000-04-15 Application 0 143
The macros 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() Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As String Dim fontName As String, i As Long, fontCount As Long, fontSize As Integer Dim stdFont As String fontSize = 0 fontSize = InputBox("Enter Sample Font Size Between 8 And 30", "Select Sample Font Size", 12) 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 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 Documents.Add stdFont = ActiveDocument.Paragraphs(1).Range.Font.Name ' add heading With ActiveDocument.Paragraphs(1).Range .Text = "Installed fonts:" End With LS 2 ' list font names and font example on every other line For i = 0 To FontNamesCtrl.ListCount - 1 fontName = FontNamesCtrl.List(i + 1) If i Mod 5 = 0 Then Application.StatusBar = "Listing font " & _ Format(i / (fontCount - 1), "0 %") & " " & _ fontName & "..." With ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range .Text = fontName .Font.Name = stdFont End With LS 1 tFormula = "abcdefghijklmnopqrstuvwxyz" If Application.International(wdProductLanguageID) = 47 Then tFormula = tFormula & "æøå" End If tFormula = tFormula & UCase(tFormula) tFormula = tFormula & "1234567890" With ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range .Text = tFormula .Font.Name = fontName End With LS 2 Next i ActiveDocument.Content.Font.Size = fontSize Application.StatusBar = False If Not FontCmdBar Is Nothing Then FontCmdBar.Delete Set FontCmdBar = Nothing Set FontNamesCtrl = Nothing ActiveDocument.Saved = True Application.ScreenUpdating = True Application.ScreenRefresh End Sub Private Sub LS(lCount As Integer) ' adds lCount new paragraph(s) at the end of the document Dim i As Integer With ActiveDocument.Content For i = 1 To lCount .InsertParagraphAfter Next i End With End Sub