Public Sub XocListFonts()
On Error GoTo ErrorHandler
Dim rngStory As Range
Dim rngChar As Range
Dim strsFontNames As Collection
Dim strFontOld As String
Dim strFontCur As String
Dim strFontName As String
Dim objFontName As Variant
Dim Number As Integer
Dim strFonts As String
Set strsFontNames = New Collection
For Each rngStory In ActiveDocument.StoryRanges
strFontOld = ""
If rngStory.End > 1 Then
Set rngChar = rngStory.Characters(1)
Do
strFontCur = rngChar.Font.Name
If strFontCur <> strFontOld Then
strFontOld = strFontCur
' This causes a runtime error if the font doesn't exist
objFontName = strsFontNames.Item(strFontCur)
End If
rngChar.MoveStart wdCharacter, 1
rngChar.MoveEnd wdCharacter, 1
Loop Until rngChar.End = rngStory.End
End If
Next rngStory
For Each objFontName In strsFontNames
strFonts = strFonts & objFontName & vbCrLf
Next objFontName
MsgBox strFonts
Exit Sub
ErrorHandler:
Number = Err.Number
Select Case Number
Case 5 'Invalid Procedure Call
strsFontNames.Add strFontCur, strFontCur
Resume Next
Case Else
MsgBox "Unexpected Error #" & Number & vbCrLf & Err.Description
End Select
End Sub
An alternate way to get a list is to save the document as a PDF file. Then open the PDF file in Adobe Reader. From the File menu, select Properties. Then click the fonts tab. Adobe is a little more explicit about the fonts, differentiating Bold and Italic fonts from the normal font.
No comments :
Post a Comment
Note: Only a member of this blog may post a comment.