Word VBA/マクロ 備忘録

作業効率化のため作成したマクロをバックアップ代わりにアップしていきます。

【Word VBA/マクロ】コメントの一覧作成

サンプルコードでできること

コメントの一覧を作成します。
 1列目 コメントの挿入ページ
 2列目 作成者
 3列目 コメントの付けられた文字列
 4列目 コメント

Sub GetCommentList()
'コメントの一覧(ページ、作成者、コメントの付けられた文字列、コメント)を作成します。
    Dim cmt As Comment
    Dim cmtList As String, docNew As Document
    For Each cmt In ActiveDocument.Comments
        With cmt
            cmtList = cmtList & .Reference.Information(wdActiveEndPageNumber) _
                & vbTab & .Contact.Name & vbTab & _
                cmt.Scope.Text & vbTab & .Range.Text & vbCrLf
        End With
    Next
    If cmtList = "" Then
        MsgBox "コメントはありません"
        Exit Sub
    Else
        '新規文書作成(数値は余白の数値)
        Set docNew = GetNewDocument(30, 30, 30, 30)
        docNew.Range.InsertBefore cmtList
        
        '選択テキストを表に変換
        With Selection
            .WholeStory
            .ConvertToTable Separator:=wdSeparateByTabs
            .InsertRowsAbove 1
            With .Tables(1).Range
                .Cells(1).Range.Text = "ページ"
                .Cells(2).Range.Text = "作成者"
                .Cells(3).Range.Text = "コメントが付けられた文字列"
                .Cells(4).Range.Text = "コメント"
            End With
        End With
                   
        '表スタイル適用、列幅指定
        With Selection.Tables(1)
            .Style = "表 (格子)"
            .ApplyStyleHeadingRows = True
            .PreferredWidthType = wdPreferredWidthPercent
            .PreferredWidth = 100
            .Columns(1).PreferredWidth = 8
            .Columns(2).PreferredWidth = 12
            .Columns(3).PreferredWidth = 40
            .Columns(4).PreferredWidth = 40
        End With
    End If
End Sub

Private Function GetNewDocument(tMgn As Single, bMgn As Single, _
    lMgn As Single, rMgn As Single) As Document
'新規文書を作成します。
    Dim dcNew As Document
    Set dcNew = Documents.Add
    With dcNew.PageSetup
        .TopMargin = MillimetersToPoints(30)
        .BottomMargin = MillimetersToPoints(30)
        .LeftMargin = MillimetersToPoints(30)
        .RightMargin = MillimetersToPoints(30)
    End With
    Set GetNewDocument = dcNew
End Function