我们在word中，同时按alt和f11进入vb编辑器，插入-模块
在右侧的代码区域输入下列代码
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
接下来按F5运行，或者关闭vb窗口后，按alt f8运行这个宏
等待片刻后，会生成一个新的文档，在新的word文档中，会列出刚才的word中使用的所有字体
其实word的docx文档本质上都可以理解成压缩包，因为Office2007之后，采用了OOXML（Office Open XML）格式，是当前国际文档标准格式。
我们关闭word后，把这个word文档解压缩到当前文件夹
