工欲善其事

代码如下：

Public Sub 列出所有字体_一闪流溢()

On Error Resume Next

Application.ScreenUpdating = 0

Dim 所有字体$

Set 文档 = ActiveDocument

所有字体 = 获得字体(文档)

Documents.Add

ActiveDocument.Range.InsertBefore "一闪流溢提示您，刚才文档中的字体有:" & vbLf & 所有字体

Application.ScreenUpdating = 1

End Sub

Private Function 获得字体(ByVal 当前文档 As Document) As String

Dim 数量%, 所有字体$, 字体类型$, 段落 As Paragraph, 字符 As Words

For Each 段落 In 当前文档.Paragraphs

For 数量 = 1 To 段落.Range.Characters.Count

字体类型 = 段落.Range.Characters(数量).Font.Name

If InStr(1, 所有字体, 字体类型) = 0 Then

所有字体 = 所有字体 & 字体类型 & vbLf

End If

Next

Next

获得字体 = 所有字体

End Function