使用vba获取word中所有字体的名称

一、方案一

新建宏

Sub a()
    Dim str As String
    For Each c In ThisDocument.Characters
        If InStr(str, c.Font.Name) = 0 And Len(c.Font.Name) > 0 Then
            str = str & c.Font.Name & ","
        End If
    Next
    MsgBox UBound(Split(Left(str, Len(str) - 1), ",")) + 1 & "种字体，分别是" & vbCrLf & Left(str, Len(str) - 1)
End Sub

再运行宏

二、方案二

Reports all fonts used in a file, then which fonts are not present on the PC.

You receive files from others, and they often use fonts you don't have, but you're not sure, without carefully looking through the entire file, which fonts have been used. Using this code lets you check to make sure you're seeing what you're supposed to be seeing in the document. Particularly nice for desktop publishing tasks.

Option Explicit 
 
Public Sub Main() 
     
    Dim sMsg            As String 
     
    sMsg = GetFonts(ActiveDocument) 
    MsgBox "The fonts in this document are:" & vbNewLine & vbNewLine & sMsg 
    If Not CompareFonts(sMsg) = vbNullString Then 
        MsgBox "The following fonts are used in this document," & _ 
        vbNewLine & "but are not installed on this PC:" & vbNewLine & CompareFonts(sMsg) 
    End If 
     
End Sub 
 
Private Function GetFonts(ByVal oDocument As Document) As String 
     
    Dim oParagraph      As Paragraph 
    Dim i               As Integer 
    Dim oWord           As Words 
    Dim sFontType       As String 
    Dim sMsg            As String 
     
    For Each oParagraph In oDocument.Paragraphs 
        For i = 1 To oParagraph.Range.Characters.Count 
            sFontType = oParagraph.Range.Characters(i).Font.Name 
            If InStr(1, sMsg, sFontType) = 0 Then 
                sMsg = sMsg & sFontType & vbNewLine 
            End If 
        Next 
    Next 
    GetFonts = sMsg 
     
End Function 
 
Private Function CompareFonts(ByVal oFonts As String) As String 
     
    Dim vFont           As Variant 
    Dim sMsg            As String 
    Dim xFont           As Variant 
    Dim i               As Long 
    Dim allFonts        As String 
     
    For Each vFont In FontNames 
        allFonts = allFonts & vbNewLine & vFont 
    Next vFont 
    xFont = Split(oFonts, vbNewLine) 
    For i = 0 To UBound(xFont) 
        If InStr(allFonts, xFont(i)) = 0 Then 
            sMsg = sMsg & vbNewLine & xFont(i) 
        End If 
    Next i 
    CompareFonts = sMsg 
     
End Function 

1. Open Word.
2. Alt + F11 to open the VBE.
3. Insert | Module. Add the module to ThisDocument if you want it to be available with only that document, put it in Normal.dot to have it available for all documents.
4. Paste the code there.
5. Close the VBE (Alt + Q or press the X in the top-right corner).

1. Follow the instructions in the "How to use" section.
2. Tools | Macro | Macros.
3. Select Main and press Run
4. You will get a message box stating all the fonts in the document, and a second message box if any fonts are not on the computer.

附注

https://word.tips.net/T011069...

http://www.vbaexpress.com/kb/...

https://zhidao.baidu.com/ques...