Extract Section Headings for Comments?

[vbanewbie222345]

Hi all. I have a script that extracts all comments from a document. I am looking to replace the page # and line # portion of the code with the section the comment resides in. For example, there is a comment located in the Executive Summary section of a document, and the Executive Summary is section 1.1 in the Table of Contents, I want the "1.1 Executive Summary" to populate in the reference in work product column. I've been working on this for days, any help you can provide would be greatly appreciated!



Public Sub ExtractReviewComments()

Dim oDoc As Document
Dim oNewDoc As Document
Dim oTable As Table
Dim nCount As Long
Dim n As Long
Dim Title As String
Dim Version As String

Title = "Extract Review Comments"
Version = "3.01"
Set oDoc = ActiveDocument
nCount = ActiveDocument.Comments.Count

'notify user and exit when there are no comments
If nCount = 0 Then
MsgBox "This document contains no tracked comments.", vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Do you want to extract all comments to a new document?", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
End If
End If

Application.ScreenUpdating = False
'Create a new document for the comments based on Normal.dot
Set oNewDoc = Documents.Add
'Change orientation to landscape
oNewDoc.PageSetup.Orientation = wdOrientLandscape
'Insert a table for the comments
With oNewDoc
.Content = ""
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=nCount + 1, _
NumColumns:=6)
End With

'Insert header
oNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Comments extracted from: " & oDoc.FullName & vbCr & _
"Review Moderator: " & Application.UserName & vbCr & _
"Date created: " & Format(Date, "MMMM d, yyyy") & vbCr & _
"Macro version: " & Version & vbCr

'Adjust the Normal and Header styles
With oNewDoc.Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 9
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With

With oNewDoc.Styles(wdStyleHeader)
.Font.Size = 9
.ParagraphFormat.SpaceAfter = 0
End With

'Format the table
With oTable
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Columns(1).PreferredWidth = 25
.Columns(2).PreferredWidth = 40
.Columns(3).PreferredWidth = 5
.Columns(4).PreferredWidth = 5
.Columns(5).PreferredWidth = 5
.Columns(6).PreferredWidth = 10
.Rows(1).HeadingFormat = True
End With
With oTable.Borders(wdBorderTop)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = 7743232
End With
With oTable.Borders(wdBorderLeft)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = 7743232
End With
With oTable.Borders(wdBorderBottom)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = 7743232
End With
With oTable.Borders(wdBorderRight)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = 7743232
End With
With oTable.Borders(wdBorderHorizontal)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = 7743232
End With
With oTable.Borders(wdBorderVertical)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = 7743232
End With

'Insert table headings
With oTable.Rows(1)
.Range.Font.Bold = True
.Shading.BackgroundPatternColor = 7743232
.Cells(1).Range.Text = "Reference in Work Product"
.Cells(2).Range.Text = "Description"
.Cells(3).Range.Text = "Severity"
.Cells(4).Range.Text = "Status"
.Cells(5).Range.Text = "Resolution Date"
.Cells(6).Range.Text = "Submitted By"
End With

'Get info from each comment from oDoc and insert in table
For n = 1 To nCount
With oTable.Rows(n + 1)
.Cells(1).Range.Text = _
"Section " & _
oDoc.Comments.Scope.Information(wdActiveEndSectionNumber) & _
" line " & _
oDoc.Comments.Scope.Information(wdFirstCharacterLineNumber) & _
" - " & _
oDoc.Comments.Scope
'Find "severity:" in comment text, converting to lcase for case-insensitivity
i = InStr(1, LCase$(oDoc.Comments.Range.Text), LCase$("Severity:"))
'Write the comment before the "," appears
If i <> 0 Then
.Cells(2).Range.Text = Left(oDoc.Comments.Range.Text, i - 1)
'severity
.Cells(3).Range.Text = Mid(oDoc.Comments.Range.Text, i + 9)
Else
.Cells(2).Range.Text = oDoc.Comments.Range.Text
End If
.Cells(4).Range.Text = "Open"
.Cells(6).Range.Text = oDoc.Comments.Author
End With
Next n

Application.ScreenUpdating = True
Application.ScreenRefresh

oNewDoc.Activate
MsgBox nCount & " comments extracted.", vbOKOnly, Title

ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing

End Sub

 

[vbanewbie222345]

nobody?

 

[TonyJollans]

I haven't looked at your code but the difficulty with this sort of thing is that, although you consider a comment to be in what you call Section 1.1, Word has no concept of this. All that Word sees is paragraphs, some styled as Headings, some with numbers, some in TOCs.

You have, essentially, two choices. You can build a look-up table of your TOC entries (it isn't straightforward but you can interrogate the TOC) or you can scan backwards from your comments to find the heading you want.


Enjoy,
Tony

------------------------------------------------------------------------------------
We want to help you; help us to do it by reading this: Before you ask a question.

I'm working (slowly) on my own website