找出Word裡使用的字型

　　蟲蟲當客串小編輯已經有段時間，多人編寫教材時，常遇到的問題是「字型不統一」或是給出版社前，「不知道用了多少字型」。

　　這問題很複雜，有可能真的是每個人使用的字型不一樣，也有可能是電腦幫你預設了字型。當然也有可能是選錯或剪貼時沒注意到。不管這一切，重要的是如何找出有哪些字型。

　　在《Word排版藝術》一書中，侯大師提供了一段程式碼，原貼如下：

Sub findfonts()

Dim efonts As New Collection
Dim cfonts As New Collection
Dim stl As Style
Dim useCount As Integer
Dim i As Integer

useCount = 0
For i = 1 To ActiveDocument.Styles.Count
Set stl = ActiveDocument.Styles.Item(i)
If stl.InUse Then
useCount = useCount + 1
If notinit(stl.Font.Name, efonts) Then
efonts.Add stl.Font.Name
End If
If notinit(stl.Font.NameFarEast, cfonts) Then
cfonts.Add stl.Font.NameFarEast
End If
End If
Next i

Dim msg As String
Dim obj As Variant

msg = "目前:" + CStr(ActiveDocument.Styles.Count) + Chr(10)
msg = msg + "目前style:" + CStr(useCount) + Chr(10) + Chr(10)
msg = msg + "內建字型:" + CStr(efonts.Count) + Chr(10)
For Each obj In efonts
msg = msg + obj + Chr(10)
Next

msg = msg + Chr(10) + "遠東:" + CStr(cfonts.Count) + Chr(10)

For Each obj In cfonts
msg = msg + obj + Chr(10)
Next
MsgBox msg






'''''
'Dim fonts As New Collection
'Dim i As Integer
'For i = 1 To 10
' fonts.Add ActiveDocument.Styles.Item(i).Font.Name
' fonts.Add ActiveDocument.Styles.Item(i).Font.NameFarEast
'Next i
'Dim msg As String
'Dim obj As Variant
'For Each obj In fonts
' msg = msg + obj + Chr(10)
'Next
'MsgBox msg
End Sub

Function notinit(str As String, ByRef coll As Collection) As Boolean

Dim notin As Boolean
notin = True

Dim obj As Variant
For Each obj In coll
If obj = str Then
notin = False
Exit For
End If
Next

If notin Then
notinit = True

Else
notinit = False
End If


End Function



Public Sub findcha()
Dim fonts As New Collection
Dim rgn As Range

For Each rgn In ActiveDocument.Characters
If notinit(rgn.Font.Name, fonts) Then
fonts.Add rgn.Font.Name
End If

If notinit(rgn.Font.NameFarEast, fonts) Then
fonts.Add rgn.Font.NameFarEast
End If
Next

Dim msg As String
Dim obj As Variant
msg = "all" + CStr(ActiveDocument.Characters.Count) + Chr(10)
msg = msg + "all used fonts:" + CStr(fonts.Count) + Chr(10) + Chr(10)
For Each obj In fonts
msg = msg + obj + Chr(10)
Next
MsgBox msg


End Sub