Добавление кода для извлечения заголовков из комментариев Word в Excel

Question

У меня есть код для извлечения комментариев из Word в Excel.Однако он извлекает только один уровень заголовка (прямой заголовок).

Какой код можно добавить для извлечения разных уровней заголовков в отдельных столбцах в Excel?

И можно ли выбрать эти разные заголовкиуровень по стилю, например, если я использую стиль MyOwnHeading, код выберет его в качестве заголовка.

Sub ExportWordComments()

' Purpose: Search for comments in any text that's been pasted into
' this document, then export them into a new Excel spreadsheet.
' Requires reference to Microsoft Excel 16.0 Object Library in VBA,
' which should already be saved with as part of the structure of
' this .docm file.

Dim bResponse As Integer

' Exit routine if no comments have been found.
If ActiveDocument.Comments.Count = 0 Then
  MsgBox ("No comments found in this document")
  Exit Sub
Else
  bResponse = MsgBox("Do you want to export all comments to an Excel worksheet?", _
              vbYesNo, "Confirm Comment Export")
  If bResponse = 7 Then Exit Sub
End If

' Create a object to hold the contents of the
' current document and its text. (Shorthand
' for the ActiveDocument object.
Dim wDoc As Document
Set wDoc = ActiveDocument

' Create objects to help open Excel and create
' a new workbook behind the scenes.
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook

Dim i As Integer
Dim oComment As Comment         'Comment object

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False

' Create a new Workbook. Shouldn't interfere with
' other Workbooks that are already open. Will have
' at least one worksheet by default.
Set xlWB = xlApp.Workbooks.Add

With xlWB.Worksheets(1).Range("A1")

  ' Create headers for the comment information
  .Offset(0, 0) = "Comment Number"
  .Offset(0, 1) = "Page Number"
  .Offset(0, 2) = "Reviewer Name"
  .Offset(0, 3) = "Date Written"
  .Offset(0, 4) = "Comment Text"
  .Offset(0, 5) = "Section"

  ' Export the actual comments information
  For i = 1 To wDoc.Comments.Count
   Set oComment = wDoc.Comments(i)
   Set rngComment = oComment.Reference
   rngComment.Select
   Set rngHeading = wDoc.Bookmarks("\HeadingLevel").Range
   rngHeading.Collapse wdCollapseStart
   Set rngHeading = rngHeading.Paragraphs(1).Range
  .Offset(i, 0) = oComment.Index
  .Offset(i, 1) = oComment.Reference.Information(wdActiveEndAdjustedPageNumber)
  .Offset(i, 2) = oComment.Author
  .Offset(i, 3) = Format(oComment.Date, "mm/dd/yyyy")
  .Offset(i, 4) = oComment.Range
  .Offset(i, 5) = rngHeading.ListFormat.ListString & " " & rngHeading.Text
Next i

End With

' Make the Excel workbook visible
xlApp.Visible = True

' Clean up our objects
Set oComment = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
End Sub

Answer 1

Прямой заголовок, как вы его называете, получается через:

wDoc.Bookmarks("\HeadingLevel").Range
rngHeading.Collapse wdCollapseStart
Set rngHeading = rngHeading.Paragraphs(1).Range

Закладка Word "\ HeadingLevel" встроена в Word и ссылается на весь контент, связанный с данным встроенным стилем заголовка. Его нельзя использовать для других стилей. Если вы хотите получить все заголовки более высокого уровня с помощью стилей заголовков, вам нужно реализовать цикл для этого, плюс добавить логику относительно того, где и в каком порядке эти заголовки будут выводиться в вашей книге. Следующие версии вашего кода выводят заголовки по порядку в разных столбцах в одной строке. Если данный заголовок пропущен, в этом столбце нет записи.

Sub ExportWordComments()

' Purpose: Search for comments in any text that's been pasted into
' this document, then export them into a new Excel spreadsheet.
' Requires reference to Microsoft Excel Object Library in VBA,
' which should already be saved with as part of the structure of
' this .docm file.

Dim bResponse As Integer

' Exit routine if no comments have been found.
If ActiveDocument.Comments.Count = 0 Then
  MsgBox ("No comments found in this document")
  Exit Sub
Else
  bResponse = MsgBox("Do you want to export all comments to an Excel worksheet?", _
              vbYesNo, "Confirm Comment Export")
  If bResponse = 7 Then Exit Sub
End If

' Create a object to hold the contents of the
' current document and its text. (Shorthand
' for the ActiveDocument object.
Dim wdDoc As Document, wdCmt As Comment, wdRng As Range
Dim i As Long, j As Long
Set wdDoc = ActiveDocument

' Create objects to help open Excel and create
' a new workbook behind the scenes.
Dim xlApp As New Excel.Application, xlWB As Excel.Workbook, xlRng As Excel.Range
xlApp.Visible = False

' Create a new Workbook. Shouldn't interfere with
' other Workbooks that are already open. Will have
' at least one worksheet by default.
Set xlWB = xlApp.Workbooks.Add

Set xlRng = xlWB.Worksheets(1).Range("A1")
With xlRng
  ' Create headers for the comment information
  .Offset(0, 0) = "Comment Number"
  .Offset(0, 1) = "Page Number"
  .Offset(0, 2) = "Reviewer Name"
  .Offset(0, 3) = "Date Written"
  .Offset(0, 4) = "Comment Text"
  .Offset(0, 5) = "Section"
End With
  ' Export the actual comments information
With wdDoc
  For Each wdCmt In .Comments
    With wdCmt
      i = i + 1
      If I Mod 100 = 0 Then DoEvents
      xlRng.Offset(i, 0) = .Index
      xlRng.Offset(i, 1) = .Reference.Information(wdActiveEndAdjustedPageNumber)
      xlRng.Offset(i, 2) = .Author
      xlRng.Offset(i, 3) = Format(.Date, "mm/dd/yyyy")
      xlRng.Offset(i, 4) = .Range.Text
      Set wdRng = .Scope
      Set wdRng = wdRng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
      j = HeadingLevel(WdRng)
      xlRng.Offset(i, 4 + j) = WdRng.Paragraphs.First.Range.ListFormat.ListString & " " & WdRng.Text
      Do Until WdRng.Paragraphs.First.Style = wdStyleHeading1
        WdRng.Start = WdRng.Start - 1
        Set WdRng = WdRng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
        j = HeadingLevel(WdRng)
        xlRng.Offset(i, 4 + j) = WdRng.Paragraphs.First.Range.ListFormat.ListString & " " & WdRng.Text
      Loop
    End With
  Next
End With

' Make the Excel workbook visible
xlApp.Visible = True

' Clean up our objects
Set wdRng = Nothing: Set wdCmt = Nothing: Set wdDoc = Nothing
Set xlRng = Nothing: Set xlWB = Nothing: Set xlApp = Nothing
End Sub

Function HeadingLevel(WdRng As Range)
Select Case WdRng.Paragraphs.First.Style
  Case wdStyleHeading1: j = 1
  Case wdStyleHeading2: j = 2
  Case wdStyleHeading3: j = 3
  Case wdStyleHeading4: j = 4
  Case wdStyleHeading5: j = 5
  Case wdStyleHeading6: j = 6
  Case wdStyleHeading7: j = 7
  Case wdStyleHeading8: j = 8
  Case wdStyleHeading9: j = 9
End Select
End Function