ドキュメントフォントリストの作成（Microsoft Word）

Public Sub ListFontsInDoc1()

Dim FontList(199) As String   Dim FontCount As Integer   Dim FontName As String   Dim J As Integer, K As Integer, L As Integer   Dim X As Long, Y As Long   Dim FoundFont As Boolean   Dim rngChar As Range   Dim strFontList As String

FontCount = 0   X = ActiveDocument.Characters.Count   Y = 0   ' For-Next loop through every character   For Each rngChar In ActiveDocument.Characters     Y = Y + 1     FontName = rngChar.Font.Name     StatusBar = Y & ":" & X     ' check if font used for this char already in list     FoundFont = False     For J = 1 To FontCount       If FontList(J) = FontName Then FoundFont = True     Next J     If Not FoundFont Then       FontCount = FontCount + 1       FontList(FontCount) = FontName     End If   Next rngChar

' sort the list   StatusBar = "Sorting Font List"

For J = 1 To FontCount - 1     L = J     For K = J + 1 To FontCount       If FontList(L) > FontList(K) Then L = K     Next K     If J <> L Then       FontName = FontList(J)

FontList(J) = FontList(L)

FontList(L) = FontName     End If   Next J

StatusBar = ""

' put in new document   Documents.Add   Selection.TypeText Text:="There are " & _    FontCount & " fonts used in the document, as follows:"

Selection.TypeParagraph   Selection.TypeParagraph   For J = 1 To FontCount     Selection.TypeText Text:=FontList(J)

Selection.TypeParagraph   Next J End Sub

Public Sub ListFontsInDoc2()

Dim rngStory As Word.Range   Dim rngChar As Range   Dim oShp As Word.Shape   Dim FontName As String   Dim lngIndex As Long   Dim lngChar As Long   Dim lngCharCount As Long   Dim colFontsUsed As New Collection   Dim oDocList As Word.Document

For Each rngStory In ActiveDocument.StoryRanges     lngChar = 0     lngCharCount = rngStory.Characters.Count     Do       'Evaluate each character       Set rngChar = rngStory.Characters(1)

If rngStory.End > 1 Then         Do           lngChar = lngChar + 1           FontName = rngChar.Font.Name           StatusBar = "Evaluauting character " & lngChar & _            " of " & lngCharCount & " characters in the story range"

'Check if font used for this character already in list           On Error Resume Next           'Collection key prevents adding fonts already           'in the collection           colFontsUsed.Add rngChar.Font.Name, rngChar.Font.Name           On Error GoTo 0           rngChar.MoveStart wdCharacter, 1           rngChar.MoveEnd wdCharacter, 1           'Set rngChar = rngChar.Next '         Loop Until rngChar.End = rngStory.End       End If

'Evaluate shapes in headers and footers       Select Case rngStory.StoryType         Case 6, 7, 8, 9, 10, 11           'No shape will throw an error that we handle and skip           On Error GoTo Err_Handler           If rngStory.ShapeRange.Count > 0 Then             For Each oShp In rngStory.ShapeRange               If oShp.TextFrame.HasText Then                 lngChar = 0                 lngCharCount = oShp.TextFrame.TextRange.Characters.Count                 For Each rngChar In oShp.TextFrame.TextRange.Characters                   lngChar = lngChar + 1                   FontName = rngChar.Font.Name                   StatusBar = "Evaluauting character " & _                    lngChar & " of " & lngCharCount & _                    " characters in the story range"

On Error Resume Next                   colFontsUsed.Add rngChar.Font.Name, rngChar.Font.Name                   On Error GoTo 0                 Next rngChar               End If             Next oShp           End If         Case Else           'Do Nothing       End Select

SkipRange:

On Error GoTo 0       'Get next linked story (if any)

Set rngStory = rngStory.NextStoryRange     Loop Until rngStory Is Nothing   Next rngStory   'Sort the collection.

StatusBar = "Sorting Font List"

Set colFontsUsed = SortCollection(colFontsUsed)

StatusBar = ""

'Create font list document.

Set oDocList = Documents.Add   With oDocList.Range     .Text = "There are " & colFontsUsed.Count & _      " fonts used in the document, as follows:" & vbCr & vbCr     For lngIndex = 1 To colFontsUsed.Count       .InsertAfter colFontsUsed(lngIndex) & vbCr     Next lngIndex   End With   Set oDocList = Nothing   Exit Sub

Err_Handler:

Resume SkipRange End Sub

Public Function SortCollection(ByVal oCol As Collection) As Collection   Dim arrIndex() As Long   Dim lngCount As Long   Dim i As Long   Dim m As Long   Dim oColSorted As New Collection

lngCount = oCol.Count   If lngCount = 0 Then     Set SortCollection = New Collection     Exit Function   End If

'Allocate an index array.

ReDim arrIndex(0 To lngCount - 1) As Long   'Fill the index array.

For i = 0 To lngCount - 1     arrIndex(i) = i + 1   Next i

'Generate an ordered heap   For i = lngCount/2 - 1 To 0 Step -1     Heapify oCol, arrIndex, i, lngCount   Next i

'Sort the index array   For m = lngCount To 2 Step -1     Exchange arrIndex, 0, m - 1     Heapify oCol, arrIndex, 0, m - 1   Next   For i = 0 To lngCount - 1     oColSorted.Add oCol.Item(arrIndex(i))

Next ' fill output collection   Set SortCollection = oColSorted End Function

Private Sub Heapify(oCol As Collection, arrIndexPasssed() As Long, _  lngIndex As Long, lngCount As Long)

Dim lngMidCount As Long   Dim i As Long   lngMidCount = lngCount/2

Do While lngIndex < lngMidCount     i = 2 * lngIndex + 1     If i + 1 < lngCount Then       If oCol.Item(arrIndexPasssed(i)) < oCol.Item(arrIndexPasssed(i + 1)) _        Then i = i + 1     End If     If oCol.Item(arrIndexPasssed(lngIndex)) >= oCol.Item(arrIndexPasssed(i)) _      Then Exit Do     Exchange arrIndexPasssed, lngIndex, i     lngIndex = i   Loop End Sub

Private Sub Exchange(Index() As Long, i As Long, j As Long)

Dim Temp As Long   Temp = Index(i)

Index(i) = Index(j)

Index(j) = Temp End Sub