Word VBA技术：提取文档中的所有批注并在新文档中放置其详细信息

Sub ExtractComments()
 Dim objDoc As Document
 Dim objNewDoc As Document
 Dim objTable As Table
 Dim lngCount As Long
 Dim lngN As Long
 Dim strTitle As String

 strTitle = "提取所有批注到新文档"
 Set objDoc = ActiveDocument
 lngCount = ActiveDocument.Comments.Count

 If lngCount = 0 Then
   MsgBox "当前文档没有包含批注.",vbOKOnly, strTitle
   GoTo ExitHere
 Else
   If MsgBox("你想提取所有批注到新文档?",vbYesNo + vbQuestion, strTitle) <> vbYes Then
     GoTo ExitHere
   End If
 End If

 Application.ScreenUpdating = False
'创建一个新文档来放置提取的批注
 Set objNewDoc = Documents.Add
 objNewDoc.PageSetup.Orientation = wdOrientLandscape
 '插入一个包含5列的表来呈现批注信息
 With objNewDoc
   .Content = ""
   Set objTable = .Tables.Add(Range:=Selection.Range, _
     NumRows:=lngCount + 1, _
     NumColumns:=5)
 End With

 '插入页眉内容
 objNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
    "批注所在文档：" & objDoc.FullName & vbCr & _
    "文档创建者：" & Application.UserName & vbCr & _
    "创建日期：" & Format(Date, "yyyy-mm-d")

 '设置文档样式和页眉样式
 With objNewDoc.Styles(wdStyleNormal)
   .Font.Name = "微软雅黑"
   .Font.Size = 10
   .ParagraphFormat.LeftIndent = 0
   .ParagraphFormat.SpaceAfter = 6
 End With

 With objNewDoc.Styles(wdStyleHeader)
   .Font.Size = 8
   .ParagraphFormat.SpaceAfter = 0
   .ParagraphFormat.Alignment = wdAlignParagraphLeft
 End With

 '格式化表格
 With objTable
   .Range.Style = wdStyleNormal
   .AllowAutoFit = False
   .PreferredWidthType = wdPreferredWidthPercent
   .PreferredWidth = 100
   .Columns.PreferredWidthType = wdPreferredWidthPercent
   .Columns(1).PreferredWidth = 5
   .Columns(2).PreferredWidth = 23
   .Columns(3).PreferredWidth = 42
   .Columns(4).PreferredWidth = 18
   .Columns(5).PreferredWidth = 12
   .Rows(1).HeadingFormat = True
   .Style = "网格型"
 End With

 '插入表格标题
 With objTable.Rows(1)
   .Range.Font.Bold = True
  .Cells(1).Range.Text = "页码"
  .Cells(2).Range.Text = "批注文字作用范围"
  .Cells(3).Range.Text = "批注文本"
  .Cells(4).Range.Text = "作者"
  .Cells(5).Range.Text = "日期"
 End With

'从文档中获取每个批注的信息并插入到表格
 For lngN = 1 To lngCount
   With objTable.Rows(lngN + 1)
     '页码
     .Cells(1).Range.Text = objDoc.Comments(lngN).Scope.Information(wdActiveEndAdjustedPageNumber)
     '被批注标记的文本
     .Cells(2).Range.Text = objDoc.Comments(lngN).Scope
     '批注内容
     .Cells(3).Range.Text = objDoc.Comments(lngN).Range.Text
     '批注者
     .Cells(4).Range.Text = objDoc.Comments(lngN).Author
     '批注的日期
     .Cells(5).Range.Text = Format(objDoc.Comments(lngN).Date, "yyyy-mm-d")
   End With
 Next lngN

 Application.ScreenUpdating = True
 Application.ScreenRefresh

 objNewDoc.Activate
 MsgBox "已发现" & lngCount & "条批注.", vbOKOnly,strTitle
 
ExitHere:
 Set objDoc = Nothing
 Set objNewDoc = Nothing
 Set objTable = Nothing
End Sub