Word all fonts macro

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

Please Note:
This article is written for users of the following Microsoft Word versions: 2007, 2010, and 2013. If you are using an earlier version (Word 2003 or earlier), this tip may not work for you. For a version of this tip written specifically for earlier versions of Word, click here: Creating a Document Font List.

Word allows you to use the fonts that are installed on the system you are using. Fonts are installed within Windows, so that they are available not just to Word, but to all programs installed on your system.

When you are creating a document on your system, it is easy to know what fonts are being used—the list of fonts is limited to those available on the system. If you receive a document from a different person, however, the other person’s system may have different fonts installed than you do. This means that their Word document could be formatted with fonts you don’t even have on your system.

If you want to generate a list of fonts used within a document (as opposed to a list of fonts available on a system), you have a couple of choices. First of all, you can open the Word document in a text editor and look around in the parts of the document you don’t normally see in Word. Near the end of the file you should see a list of fonts used in the document. If you do this, however, you should be very careful to not make any changes to the Word document while it is open in your text editor. Doing so can easily make the document no longer usable in Word.

A Word-based solution is to simply look through each character in a document and check out what font is used to format the character. A character-by-character approach is necessary because each character could be formatted with a different font, and VBA doesn’t allow you to access a fonts collection in relation to the document itself—it seems that no such collection is maintained. Thus, the safest (and slowest) method is to simply step through each character and create your own list. The following VBA macro accomplishes the task:

Public Sub ListFontsInDoc()
    Dim FontList(199) As String
    Dim FontCount As Integer
    Dim FontName As String
    Dim J As Integer, K As Integer, L As Integer
    Dim X As Long, Y As Long
    Dim FoundFont As Boolean
    Dim rngChar As Range
    Dim strFontList As String

    FontCount = 0
    X = ActiveDocument.Characters.Count
    Y = 0
    ' For-Next loop through every character
    For Each rngChar In ActiveDocument.Characters
        Y = Y + 1
        FontName = rngChar.Font.Name
        StatusBar = Y & ":" & X
        ' check if font used for this char already in list
        FoundFont = False
        For J = 1 To FontCount
           If FontList(J) = FontName Then FoundFont = True
        Next J
        If Not FoundFont Then
            FontCount = FontCount + 1
            FontList(FontCount) = FontName
        End If
    Next rngChar

    ' sort the list
    StatusBar = "Sorting Font List"
    For J = 1 To FontCount - 1
        L = J
        For K = J + 1 To FontCount
            If FontList(L) > FontList(K) Then L = K
        Next K
        If J <> L Then
            FontName = FontList(J)
            FontList(J) = FontList(L)
            FontList(L) = FontName
        End If
    Next J

    StatusBar = ""
    ' put in new document
    Documents.Add
    Selection.TypeText Text:="There are " & _
      FontCount & " fonts used in the document, as follows:"
    Selection.TypeParagraph
    Selection.TypeParagraph
    For J = 1 To FontCount
        Selection.TypeText Text:=FontList(J)
        Selection.TypeParagraph
    Next J
End Sub

Obviously, the longer your document, the longer it will take the macro to finish. (I ran the macro on an 1,100 page document and it took approximately 46 minutes. On a 5 page document it took less than a minute.) When done, the macro creates a new document that contains a sorted list of the fonts used.

Author Bio

With more than 50 non-fiction books and numerous magazine articles to his credit, Allen Wyatt is an internationally recognized author. He is president of Sharon Parq Associates, a computer and publishing services company. Learn more about Allen…

Доброй ночи, адепты)
Вы не раз меня выручали, уповаю на вашу помощь и теперь!

Скажем есть некий текст, набранный Times New Roman-ом, и среди него встречаются слова которые почему то решили быть набраны Arial-ом. (такой документик я прилепил к сообщению)

Надо бы чтобы Ариалы не отбивались от общего настроения и тоже стали Таймсами
Это легко лечится заменой, но хотелось бы делать это нажатием одной кнопки.

Однако, когда я записываю макрос, который должен повторить мои действия по замене всех Ариалов на Таймсы, то он выглядит следующим образом и не работает. В чем же дело? помогите пожалуйста (( желательно детсадовским языком, ибо я не программист.

Спасибо)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

Sub testing()
'
' testing Macros
'
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub