Word VBA スタイル一覧

Option Explicit

Sub 対象Word文書の全てのスタイルを取得()

   Dim 現在のパス As String
   Dim カウンタ文書 As Integer
   Dim カウンタstyle As Integer
   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim フォルダ As Object
   Dim ファイル As Object
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   Dim 処理文書 As Document
   Dim ファイル名 As String
   Dim スタイル As Object
   Dim 文字列 As String
   Dim フッタ As HeaderFooter
    
   開始日時 = Now                ' 開始時刻を変数に格納します。

   現在のパス = ActiveDocument.Path
   ActiveDocument.Content.Delete '既表示内容を消去する
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
      
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス)

   '★このマクロのWord 文書の存在するフォルダの全てのファイルを対象
   For Each ファイル In フォルダ.Files
      
      ファイル名 = ファイル.Path

      If Mid(ファイル名, InStrRev(ファイル名, ".") + 1, 3) = "doc" Then
      
         If Dir(ファイル名) <> ThisDocument.Name _
         And Len(Dir(ファイル名)) <> 0 Then '自分自身と、ロック用の一時ファイル~$は対象外
'Stop
            カウンタ文書 = カウンタ文書 + 1
            文字列 = ""
            
            Set 処理文書 = Documents.Open(FileName:=ファイル名) '文書ファイルを開く
            
            文字列 = CStr(カウンタ文書) & String(10, "★") & vbNewLine
            文字列 = 文字列 & "ファイル名: " & ファイル名 & vbNewLine
            
            カウンタstyle = 0
            For Each スタイル In 処理文書.Styles
               カウンタstyle = カウンタstyle + 1

               文字列 = 文字列 & CStr(カウンタ文書) & " ☆ " & CStr(カウンタstyle) _
                  & " ★ Style Name: " & スタイル.NameLocal & vbNewLine
               文字列 = 文字列 & "Font Name: " & スタイル.Font.Name & vbNewLine
               文字列 = 文字列 & "Font Size: " & スタイル.Font.Size & vbTab
               文字列 = 文字列 & "Bold: " & スタイル.Font.Bold & vbTab
               文字列 = 文字列 & "Italic: " & スタイル.Font.Italic & vbNewLine
            Next
            
            処理文書.Close savechanges:=False           '保存せずに文書ファイルを閉じる
             
            Set 処理文書 = Nothing
             ' 結果表示
             
            ThisDocument.Activate
            Selection.TypeText Text:=文字列
            Selection.Collapse Direction:=wdCollapseEnd
            Selection.InsertBreak
             
         End If
     End If

   Next '★ファイル

   Set フォルダ = Nothing
   Set ファイルシステムオブジェクト = Nothing
   
   
   Selection.WholeStory
   Selection.Font.Name = "ＭＳ 明朝"
   Selection.Font.Size = 10
   
   
   Selection.MoveDown Unit:=wdLine, Count:=4
   With Selection.ParagraphFormat
      .LeftIndent = MillimetersToPoints(0)
      .RightIndent = MillimetersToPoints(0)
      .SpaceBefore = 0
      .SpaceBeforeAuto = False
      .SpaceAfter = 0
      .SpaceAfterAuto = False
'      .LineSpacingRule = wdLineSpaceSingle '行間一行
      .LineSpacingRule = wdLineSpaceAtLeast '行間最小
      .LineSpacing = 12                     '行間12
      .Alignment = wdAlignParagraphJustify
      .WidowControl = False
      .KeepWithNext = False
      .KeepTogether = False
      .PageBreakBefore = False
      .NoLineNumber = False
      .Hyphenation = True
      .FirstLineIndent = MillimetersToPoints(0)
      .OutlineLevel = wdOutlineLevelBodyText
      .CharacterUnitLeftIndent = 0
      .CharacterUnitRightIndent = 0
      .CharacterUnitFirstLineIndent = 0
      .LineUnitBefore = 0
      .LineUnitAfter = 0
      .MirrorIndents = False
      .TextboxTightWrap = wdTightNone
      .AutoAdjustRightIndent = True
      .DisableLineHeightGrid = True
      .FarEastLineBreakControl = True
      .WordWrap = True
      .HangingPunctuation = True
      .HalfWidthPunctuationOnTopOfLine = False
      .AddSpaceBetweenFarEastAndAlpha = True
      .AddSpaceBetweenFarEastAndDigit = True
      .BaseLineAlignment = wdBaselineAlignAuto
   End With
   
   
   With Selection.PageSetup
      .LayoutMode = wdLayoutModeDefault
   End With
   
   'フッタにページ番号挿入
   Set フッタ = ActiveDocument.Sections(1).Footers(1)
   フッタ.PageNumbers.Add _
        PageNumberAlignment:=wdAlignPageNumberCenter, _
        FirstPage:=True
   Set フッタ = Nothing

   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
End Sub

For Each aDoc In Documents
    aName = aName & aDoc.Name & vbCr
Next aDoc
MsgBox aName

Documents.Add

Documents.Open FileName:="C:\My Documents\Sales.doc"

Documents("Report.doc").Close SaveChanges:=wdDoNotSaveChanges

Documents(1).Activate

For Each doc In Documents
    If doc.Name = "Report.doc" Then found = True
Next doc
If found <> True Then 
    Documents.Open FileName:="C:\Documents\Report.doc"
Else
    Documents("Report.doc").Activate
End If

Documents.Add.Save

Dim docLoop As Document

For Each docLoop In Documents
   If docLoop.Saved = False Then docLoop.Save
Next docLoop

Dim docLoop As Document

For Each docLoop In Documents
    With docLoop
        .PageSetup.LeftMargin = InchesToPoints(0.5)
        .PageSetup.RightMargin = InchesToPoints(0.5)
        .PrintOut
    End With
Next docLoop

Documents.Open FileName:="C:\Files\Doc.doc", ReadOnly:=True

Documents("Report.doc").Close SaveChanges:=wdDoNotSaveChanges

Documents(1).Activate

Documents("Document1").Activate
ActiveDocument.PageSetup.Orientation = wdOrientLandscape
ActiveDocument.PrintOut

If Application.Documents.Count >= 1 Then
    MsgBox ActiveDocument.Name
Else
    MsgBox "No documents are open"
End If

Dim rngTemp As Range

Selection.Collapse Direction:=wdCollapseStart
Set rngTemp = ActiveDocument.Range(Start:=Selection.Start, _
    End:=Selection.Start + 5)

Dim rngTemp As Range

Set rngTemp = ActiveDocument.Range(Start:=0, End:=0)
With rngTemp
    .InsertBefore "Company Report"
    .Font.Name = "Arial"
    .Font.Size = 24
    .InsertParagraphAfter
End With

ActiveDocument.PrintOut

Sub DeleteSelection()
    Dim intResponse As Integer
    
    intResponse = MsgBox("Are you sure you want to " & _
        "delete the contents of the document?", vbYesNo)
    
    If intResponse = vbYes Then
        ActiveDocument.Content.Select
        Selection.Delete
    End If
End Sub

Selection.Copy

Documents(3).ActiveWindow.Selection.Cut

ActiveDocument.ActiveWindow.Panes(1).Selection.Copy
ActiveDocument.ActiveWindow.Panes(2).Selection.Paste

Dim strTemp as String

strTemp = Selection.Text
If Right(strTemp, 1) = vbCr Then _
    strTemp = Left(strTemp, Len(strTemp) - 1)

Selection.EndOf Unit:=wdStory, Extend:=wdMove
Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
Selection.MoveUp Unit:=wdLine, Count:=2, Extend:=wdExtend

Options.ReplaceSelection = True
ActiveDocument.Sentences(1).Select
Selection.TypeText "Material below is confidential."
Selection.TypeParagraph

With Documents(1)
    .Paragraphs.Last.Range.Select
    .ActiveWindow.Selection.Cut
End With

With Documents(2).ActiveWindow.Selection
    .StartOf Unit:=wdStory, Extend:=wdMove
    .Paste
End With

If Selection.Font.Name = "Times New Roman" Then _
    Selection.Font.Name = "Tahoma"

If Selection.Type = wdSelectionIP Then
    MsgBox Prompt:="You have not selected any text! Exiting procedure..."
    Exit Sub
End If

If Selection.Type <> wdSelectionNormal Then
    MsgBox Prompt:="選択範囲が正しくありません。プロシージャを終了します。"
    Exit Sub
End If

If Selection.Type = wdSelectionNormal Then MsgBox Selection.Text

With Selection.Font
    .Bold = True
    .Italic = False
    .Name = "Arial"
End With

If Selection.Information(wdWithInTable) = False Then 
    Selection.GoToNext What:=wdGoToTable
End If

Set myRange = ActiveDocument.Range(Start:=0, End:=10)

Set aRange = ActiveDocument.Paragraphs(1).Range

Set aRange = ActiveDocument.Range( _
    Start:=ActiveDocument.Paragraphs(2).Range.Start, _
    End:=ActiveDocument.Paragraphs(4).Range.End)

Sub SelectFirstWord()
    ActiveDocument.Words(1).Select
End Sub

Sub FormatSelection()
    Selection.Paragraphs.LeftIndent = InchesToPoints(0.5)
End Sub

Sub InsertTextAfterSelection()
    Selection.InsertAfter Text:="はじめまして "
End Sub

Sub BoldSelectedText()
    Selection.Font.Bold = True
End Sub

Sub Macro()
    Selection.HomeKey Unit:=wdStory
    Selection.MoveRight Unit:=wdWord, Count:=2, Extend:=wdExtend
    Selection.Font.Bold = wdToggle
End Sub

Sub WorkingWithRanges()
    ActiveDocument.Range(Start:=0, _
        End:=ActiveDocument.Words(2).End).Bold = True
End Sub

Sub SelectTable()
    ActiveDocument.Tables(1).Select
End Sub

Sub SelectField()
    ActiveDocument.Fields(1).Select
End Sub

Sub SelectRange()
    Dim rngParagraphs As Range
    Set rngParagraphs = ActiveDocument.Range( _
        Start:=ActiveDocument.Paragraphs(1).Range.Start, _
        End:=ActiveDocument.Paragraphs(4).Range.End)
    rngParagraphs.Select
End Sub

Sub SetNewRange()
    Dim rngDoc As Range
    Set rngDoc = ActiveDocument.Range(Start:=0, End:=10)
End Sub

Sub SetBoldRange()
    Dim rngDoc As Range
    Set rngDoc = ActiveDocument.Range(Start:=0, End:=10)
    rngDoc.Bold = True
End Sub

Sub BoldRange()
    ActiveDocument.Range(Start:=0, End:=10).Bold = True
End Sub

Sub InsertTextBeforeRange()
    Dim rngDoc As Range
    Set rngDoc = ActiveDocument.Range(Start:=0, End:=0)
    rngDoc.InsertBefore "Hello "
End Sub

Sub NewRange()
    Dim doc As Document
    Dim rngDoc As Range

    Set doc = ActiveDocument
    Set rngDoc = doc.Range(Start:=doc.Paragraphs(2).Range.Start, _
        End:=doc.Paragraphs(3).Range.End)
End Sub

Sub SetParagraphRange()
    Dim rngParagraph As Range
    Set rngParagraph = ActiveDocument.Paragraphs(1).Range
End Sub

Sub FormatRange()
    ActiveDocument.Paragraphs(2).Range.Select
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
End Sub

Sub FormatFirstParagraph()
    Dim rngParagraph As Range
    Set rngParagraph = ActiveDocument.Paragraphs(1).Range
    With rngParagraph
        .Bold = True
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
        With .Font
            .Name = "Stencil"
            .Size = 15
        End With
    End With
End Sub

Sub ExpandRange()
    Dim rngParagraph As Range
    Set rngParagraph = Selection.Range
    rngParagraph.SetRange Start:=rngParagraph.Start, _
        End:=rngParagraph.End + 10
End Sub

Sub SelectRange()
    Dim rngParagraph As Range

    Set rngParagraph = ActiveDocument.Paragraphs(2).Range

    rngParagraph.SetRange Start:=rngParagraph.Start, _
        End:=ActiveDocument.Paragraphs(3).Range.End
    rngParagraph.Select

    Selection.Font.Italic = True
End Sub

Selection.InsertBreak Type:=wdSectionBreakContinuous

Selection.Collapse Direction:=wdCollapseStart

Set mainStory = ActiveDocument.Content
Set mainStory = ActiveDocument.StoryRanges(wdMainTextStory)

Set myRange = ActiveDocument.Content
With myRange.Font
    .Name = "Arial"
    .Size = 10
End With

For Each aDocument In Documents
    If InStr(LCase$(aDocument.Name), "changes.doc") Then
        Set myRange = Documents("Changes.doc").Content
        myRange.InsertAfter "the end."
    End If
Next aDocument

ActiveDocument.PageSetup.LayoutMode = wdLayoutModeGenko

ActiveDocument.Sections(1).PageSetup.Orientation = _
    wdOrientLandscape
ActiveDocument.PrintOut

With Documents("Sales.doc").PageSetup
    .LeftMargin = InchesToPoints(0.75)
    .RightMargin = InchesToPoints(0.75)
    .TopMargin = InchesToPoints(1.5)
    .BottomMargin = InchesToPoints(1)
End With

For Each sty In ActiveDocument.Styles
    If sty.BuiltIn = False Then sty.Delete
Next sty

Set myStyle = ActiveDocument.Styles.Add(Name:="Introduction", _
    Type:=wdStyleTypeCharacter)
With myStyle.Font
    .Bold = True
    .Italic = True
    .Name = "Arial"
    .Size = 12
End With
Selection.Range.Style = "Introduction"

ActiveDocument.Styles("Color").Font.Name = "Arial"

ActiveDocument.Styles(wdStyleHeading1).Font.Bold = False

MsgBox "Base style= " _
    & ActiveDocument.Styles(1).BaseStyle & vbCr _
    & "Style name= " & ActiveDocument.Styles(1).NameLocal

Set aDoc = ActiveDocument.AttachedTemplate.OpenAsDocument
With aDoc
    .Styles(wdStyleHeading1).Font.Name = "Arial"
    .Close SaveChanges:=wdSaveChanges
End With

For Each aDoc In Documents
    aDoc.UpdateStyles
    aDoc.Close SaveChanges:=wdSaveChanges
Next aDoc

Set aDoc = ActiveDocument.AttachedTemplate.OpenAsDocument
With aDoc.Styles(wdStyleHeading1).Font
    .Name = "Arial"
    .Bold = False
End With
aDoc.Close SaveChanges:=wdSaveChanges
ActiveDocument.UpdateStyles

Selection.ParagraphFormat.Alignment = wdAlignParagraphRight

Set myRange = Documents("MyDoc.doc").Content
With myRange.ParagraphFormat
    .Space2
    .TabStops.Add Position:=InchesToPoints(.25)
End With

With ActiveDocument.Styles(wdStyleHeading2).ParagraphFormat
    .TabIndent(1)
    .Space2
End With

With ActiveDocument.Content.Find
    .ClearFormatting
    .ParagraphFormat.Space2
    .Replacement.ClearFormatting
    .Replacement.ParagraphFormat.Space15
    .Execute FindText:="", ReplaceWith:="", _
        Replace:=wdReplaceAll
End With

ActiveDocument.Paragraphs(3).Format.Alignment = _
    wdAlignParagraphCenter

With Selection.Find
    .ClearFormatting
    .ParagraphFormat.LineSpacingRule = wdLineSpaceDouble
    .Text = ""
    .Forward = True
    .Wrap = wdFindContinue
End With
Selection.Find.Execute

Dim myParaF As New ParagraphFormat
myParaF.Alignment = wdAlignParagraphCenter
myParaF.Borders.Enable = True
ActiveDocument.Paragraphs(1).Format = myParaF

Set myDup = ActiveDocument.Paragraphs(1).Format.Duplicate
myDup.LeftIndent = MillimetersToPoints(25)
Documents.Add
Selection.InsertAfter "これは新しい段落です。"
Selection.Paragraphs.Format = myDup

For Each sec In ActiveDocument.Sections
    sec.PageSetup.Orientation = wdOrientLandscape
Next sec

Set myDoc = Documents.Add
Selection.InsertAfter "これは、最初のセクションです。"
Set mysec = myDoc.Sections.Add
mysec.Range.InsertAfter "これは、2 番目のセクションです。"

With ActiveDocument.Sections.Last.Range
    .Collapse Direction:=wdCollapseEnd
    .InsertAfter "end of document"
End With

Set myRange = ActiveDocument.Range(Start:=0, End:=0)
ActiveDocument.Sections.Add Range:=myRange
myRange.InsertParagraphAfter

MsgBox ActiveDocument.Sections.Count & " sections"
Selection.Paragraphs(1).Range.InsertBreak _
    Type:=wdSectionBreakContinuous
MsgBox ActiveDocument.Sections.Count & " sections"

With ActiveDocument.Sections(1).PageSetup
    .LeftMargin = InchesToPoints(15)
    .RightMargin = InchesToPoints(15)
End With

With ActiveDocument.Sections(1).PageSetup
    .LeftMargin = InchesToPoints(0.5)
    .RightMargin = InchesToPoints(0.5)
End With

Set myRange = ActiveDocument.Range(Start:=0, End:=0)
ActiveDocument.Sections.Add Range:=myRange
myRange.InsertParagraphAfter

Selection.Paragraphs(1).Range.InsertBreak _
    Type:=wdSectionBreakContinuous

With ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary)
    .PageNumbers.Add _
        PageNumberAlignment:=wdAlignPageNumberCenter, _
        FirstPage:=False
End With

ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter = True
With ActiveDocument.Sections(1).Headers(wdHeaderFooterFirstPage)
    .Range.InsertAfter("先頭ページ")
    .Range.Paragraphs.Alignment = wdAlignParagraphRight
End With

With ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary)
    If .Range.Text <> vbCr Then
        MsgBox .Range.Text
    Else
        MsgBox "フッターには何も入力されていません。"
    End If
End With

With ActiveDocument.Sections(1)
    .Headers(wdHeaderFooterPrimary).Range.Text = "ヘッダー文字列"
    .Footers(wdHeaderFooterPrimary).Range.Text = "フッター文字列"
End With

With ActiveDocument
    .PageSetup.DifferentFirstPageHeaderFooter = True
    .Sections(1).Footers(wdHeaderFooterFirstPage) _
        .Range.InsertBefore _
        "Written by 石田 久美"
End With

With ActiveDocument.Sections(1)
    .PageSetup.DifferentFirstPageHeaderFooter = True
    .Footers(wdHeaderFooterPrimary).PageNumbers.Add _
        FirstPage:=True
End With

With ActiveDocument.Sections(1)
    .Headers(wdHeaderFooterPrimary).Range.Text = "ヘッダー文字列"
    .Footers(wdHeaderFooterPrimary).Range.Text = "フッター文字列"
End With

With ActiveDocument
    .PageSetup.DifferentFirstPageHeaderFooter = True
    .Sections(1).Footers(wdHeaderFooterFirstPage) _
        .Range.InsertBefore _
        "作成者 : 増田 聡一郎"
End With

With ActiveDocument.Sections(1)
    .Footers(wdHeaderFooterPrimary).PageNumbers.Add
End With

With ActiveDocument.ActiveWindow.View
    .Type = wdPrintView
    .SeekView = wdSeekCurrentPageFooter
End With
Selection.HeaderFooter.PageNumbers.Add _
    PageNumberAlignment:=wdAlignPageNumberCenter

With ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary)
    .PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberRight
End With

ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary) _
    .PageNumbers(1).Alignment = wdAlignPageNumberCenter

With ActiveDocument.Sections(1)
    .Footers(wdHeaderFooterPrimary).PageNumbers.Add _
        PageNumberAlignment:=wdAlignPageNumberLeft, _
        FirstPage:=False
End With

Sub DocumentRange()
    ActiveDocument.Range(Start:=0, End:=10).Bold = True
End Sub

Sub DocumentRange2()
    Dim r As Range
    Set r = ActiveDocument.Range(Start:=0, End:=Selection.End)
    r.Case = wdUpperCase
End Sub

Sub DocumentRange3()
    Dim aDoc As Document
    Dim myRange As Range
    Set aDoc = ActiveDocument
    If aDoc.Paragraphs.Count >= 6 Then
        Set myRange = aDoc.Range(aDoc.Paragraphs(2).Range.Start, _
            aDoc.Paragraphs(4).Range.End)
        myRange.Paragraphs.Alignment = wdAlignParagraphRight
    End If
End Sub

ActiveDocument.Paragraphs(1).Range.Style = wdStyleHeading1

If ActiveDocument.Tables.Count >= 1 Then _
    ActiveDocument.Tables(1).Rows(1).Cells(1).Range.Copy

Dim secLoop As Section

For Each secLoop In ActiveDocument.Sections
    If secLoop.PageSetup _
           .DifferentFirstPageHeaderFooter = True Then
        Msgbox "セクション " & secLoop.Index _
            & " では、先頭ページで他のページと異なるヘッダーとフッターが使われています。"
    End If
Next secLoop

If ActiveDocument.Footnotes.Count >= 1 Then
    With ActiveDocument.ActiveWindow.View
        .Type = wdPrintView
        .SeekView = wdSeekFootnotes
    End With
End If

ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter = True
With ActiveDocument.ActiveWindow.View
    .Type = wdPrintView
    .SeekView = wdSeekFirstPageFooter
End With

Set myView = ActiveDocument.ActiveWindow.View
If myView.SeekView = wdSeekFootnotes Or _
    myView.SeekView = wdSeekEndnotes Then
    myView.SeekView = wdSeekMainDocument
End If

With ActiveDocument.ActiveWindow.View
    .ShowAll = True
    .TableGridlines = True
    .WrapToWindow = False
End With

ActiveDocument.ActiveWindow.View.Type = wdNormalView

ActiveDocument.ActiveWindow.View.Zoom.Percentage = 120

With ActiveDocument.ActiveWindow.View
    .Type = wdPrintView
    .SeekView = wdSeekCurrentPageFooter
End With

ActiveDocument.ActiveWindow.View.FullScreen = True

Dim myPane as Pane
For Each myPane In Windows(1).Panes
    myPane.View.ShowAll = True
Next myPane

Dim myWindow as Window
For Each myWindow In Windows
    With myWindow.View
        .ShowTabs = True
        .ShowParagraphs = True
        .Type = wdNormalView
    End With
Next myWindow

Option Explicit
Option Base 1

Sub 指定ワードのフォント名と色を取得()

   Dim 現在のパス As String
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   Dim 対象文書名 As String
   Dim dicフォント As Object    ' Scripting.Dictionary
   Dim dic色 As Object
   Dim 文字 As Range            ' Charactes.Item
   Dim フォント名 As Variant    ' フォント名
   Dim フォント名一覧 As String
   Dim 色名 As Variant          ' フォント色
   Dim 色名一覧 As String
   
   ThisDocument.Activate
   現在のパス = ActiveDocument.Path
   ChDrive 現在のパス
   ChDir 現在のパス
   
   MsgBox "調査対象のワード文書を指定して下さい。"
   ChangeFileOpenDirectory ThisDocument.Path
   With Dialogs(wdDialogFileOpen)
      .Name = "*.doc*"
      If .Show = -1 Then
         対象文書名 = .Name 'パス無しの文書ファイル名
      End If
   End With
   
   If 対象文書名 = ThisDocument.Name Then
      MsgBox "選択した文書は、このファイル自身です。" & vbNewLine _
      & "調査対象のファイルを選択して下さい。"
      Exit Sub
   End If

   開始日時 = Now                ' 開始時刻を変数に格納します。
   
   Documents(対象文書名).Activate
   
   Set dicフォント = CreateObject("Scripting.Dictionary")
   Set dic色 = CreateObject("Scripting.Dictionary")

   For Each 文字 In ActiveDocument.Characters
      If dicフォント.Exists(文字.Font.Name) = False Then
        dicフォント.Add 文字.Font.Name, ""
      End If

      If dic色.Exists(文字.Font.ColorIndex) = False Then
         dic色.Add 文字.Font.ColorIndex, ""
      End If
   Next 文字

   フォント名一覧 = ""
   For Each フォント名 In dicフォント.Keys
     フォント名一覧 = フォント名一覧 & フォント名 & vbCrLf
   Next フォント名
   
   色名一覧 = ""
   For Each 色名 In dic色.Keys
     色名一覧 = 色名一覧 & 色名 & vbCrLf
   Next 色名
   
   Set dicフォント = Nothing
   Set dic色 = Nothing

   ThisDocument.Activate

   '5行目以降を消去する
   Selection.MoveDown Unit:=wdLine, Count:=5
   Selection.EndKey Unit:=wdStory, Extend:=wdExtend
   Selection.Delete Unit:=wdCharacter, Count:=1
   
   'テキストを記入するために、5行目に移動する
   Selection.MoveDown Unit:=wdLine, Count:=5
    
   With Selection
      .TypeText Text:=vbNewLine & vbNewLine & 対象文書名 & " で以下のフォントが使われています。" & vbNewLine
      .TypeText Text:=フォント名一覧 & vbNewLine & vbNewLine
      .TypeText Text:=対象文書名 & " で以下の色が使われています。" & vbNewLine
      .TypeText Text:=色名一覧
   End With

   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
   
End Sub