CODEWITHSUNDEEP
vbams-wordcross-reference
MichaelK
MichaelK

Reputation: 95

Word VBA - How to insert references of heading number; heading text; list item number and list item page number to comment?

I would like to mark certain text in my Word document and add a comment with a variety of references. This is so that a) I can output/print those details in the comments for further processing and b) that the information of the comments is updated if the document develops and changes.

The references I want to include into the comments are:

The text may look like this:

1.0 Heading A Text

This is Page 1 of the document.

1.1 Heading B Text

AB no header actually
[1] a text paragraph
[2] another text paragraph

1.1.1 Heading C Text

With this heading Page 2 starts

AB no header actually
[1] a text paragraph
[2] arbitrary paragraphs

2.0 Heading D Text

AB no header actually
[1] a text paragraph
[2] another text paragraph

2.1 Heading E Text

2.1.1 Heading F Text

AB no header actually
[1] a text paragraph
[2] another text paragraph

The desired outcome would be if MS Word balloon comments are inserted for selected words/text like in the following example for the word "arbitrary":

arbitrary ----> (Section 1.1.1 Heading C Text; Paragraph [2]; Page 2)

I already managed to extract most that is, all references except the paragraph/list item number and the paragraph page number (for the page number I use for now the page number of the heading).

This is what I have so far:

Sub InsertCommentWithReferences()

    Dim rng As Range
    Dim iLevel As Integer
    Dim sLevel As String
    Dim mystring As String
    Dim RefList As Variant
    Dim row As Integer
       
    Dim Message, Title, Default, myrequirement
    
    'To hand over additional (requirement)text to be inserted at the beginning of the comment
    'Message = "Enter the requirement number"    ' Set prompt.
    'Title = "Requirement number"    ' Set title.
    'Default = ""    ' Set default.
    'Display message, title, and default value.
    'myrequirement = InputBox(Message, Title, Default)
       
    Set rng = Selection.Range
    
    iLevel = rng.Paragraphs(1).OutlineLevel
    sLevel = "0"
    
    mystring = Selection
    sLevel = rng.ListFormat.ListString
        
    ' Collapse the range to start so as to not have to deal with '
    ' multi-segment ranges. Then check to make sure cursor is '
    ' within a table. '
    Selection.Collapse Direction:=wdCollapseStart
    If Not Selection.Information(wdWithInTable) Then
        MsgBox "Can only run this within a table"
        Exit Sub
    End If
    
    ' lookup paragraph number as a text string
    ' Here I do actually extract the paragraph number but just as string and not as a reference
    ' which can be updated if the numbering changes
    row = Selection.Information(wdEndOfRangeRowNumber)
    Selection.Tables(1).Cell(row, -1).Select
    paragraphstring = Selection.Paragraphs(1).Range.ListFormat.ListString
    'MsgBox (paragraphstring)
    
  
    Set rng = Selection.GoToPrevious(wdGoToHeading)
    If rng.Paragraphs(1).OutlineLevel < iLevel Then
        iLevel = rng.Paragraphs(1).OutlineLevel
        Set rng = rng.Bookmarks("\line").Range
        curr_headinglevel = rng.Paragraphs(1).OutlineLevel
        curr_headingnumber = Selection.Paragraphs(1).Range.ListFormat.ListString
        curr_headingtext = rng
    End If

    With Selection.Find
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Execute FindText:=mystring
    End With

    Selection.Comments.Add Range:=Selection.Range
      
    temp = curr_headingnumber & " " & curr_headingtext
    If Right(temp, 1) = vbCr Then
        temp = Left(temp, Len(temp) - 1)
    End If
      
      
    myHeadings = ActiveDocument.GetCrossReferenceItems(wdRefTypeHeading)
    For i = 1 To UBound(myHeadings)
        'debug
        'MsgBox (Trim(myHeadings(i)) & vbNewLine & temp)
        If InStr(Trim(myHeadings(i)), "  ") Then
            'debug
            'MsgBox ("double space")
            Do
                temp1 = myHeadings(i)
                myHeadings(i) = Replace(myHeadings(i), Space(2), Space(1))
            Loop Until temp1 = myHeadings(i)
        End If
        
        If InStr(Trim(myHeadings(i)), temp) Then
        
            'debug stuff
            'tempheading = myHeadings(i)
            'MsgBox ("#" & tempheading & "#")
            'If Left(tempheading, 1) = " " Then
            '    tempheading = Trim(tempheading)
            'End If
                  
            
            'Selection.TypeText Text:=("R# " & myrequirement & vbNewLine & "Section ")
            Selection.TypeText Text:=("R#" & myrequirement & "#Section ")
            
            Selection.InsertCrossReference ReferenceType:="Heading", _
                ReferenceKind:=wdNumberFullContext, _
                ReferenceItem:=CStr(i), _
                InsertAsHyperlink:=True, _
                IncludePosition:=False, _
                SeparateNumbers:=False, _
                SeparatorString:=" "
            
            Selection.TypeText Text:=(" ")
            
            Selection.InsertCrossReference ReferenceType:="Heading", _
                ReferenceKind:=wdContentText, _
                ReferenceItem:=CStr(i), _
                InsertAsHyperlink:=True, _
                IncludePosition:=False, _
                SeparateNumbers:=False, _
                SeparatorString:=" "
                                           
            Selection.TypeText Text:=("; Paragraph " & paragraphstring)
            
            Selection.TypeText Text:=("; Page ")
            
            Selection.InsertCrossReference _
                ReferenceType:=wdRefTypeHeading, _
                ReferenceKind:=wdPageNumber, ReferenceItem:=i
            
        End If
        'debug
        'MsgBox (temp & "#")
    Next i
    
    Set rng = Nothing

End Sub

What I need help with is how to identify and insert the reference of a respective list item/paragraph number into the comment? So in words this would be along the lines of: look into the cell to the left, insert a reference pointing to the list item/paragraph number which can be found in that cell into a comment (number and page number).

As you can see in the example, item numbers can repeat (restart numbering at every new heading) and, they do not have a list item text as headings would, so I cannot search for that text.

Any hints would be much appreciated. Note, I have not much experience with VBA and the above is collected from various other examples in many other Q&A threads.

Thanks so much.

Best regards, Michael.

Upvotes: 1

Views: 700

Answers (1)

macropod
macropod

Reputation: 13515

You don't need to store any of that data in the comments for later extraction. Moreover, such stored data could well be invalidated by edits that occur between the comment's creation and its extraction.

The following macro exports comments in the active document to a new Excel workbook, together with whatever headings are associated with the comment, in heading level order in different columns on the same row.

Sub ExportWordComments()
' Requires reference to Microsoft Excel Object Library in VBA,
Dim wdDoc As Document, wdCmt As Comment, wdRng As Range, i As Long, j As Long
Dim xlApp As New Excel.Application, xlWB As Excel.Workbook, xlRng As Excel.Range
xlApp.Visible = False
Set wdDoc = ActiveDocument 

' Create & prepare a new Workbook.
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
      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")
      With wdRng
        j = Split(.Paragraphs.First.Style, "Heading")(1)
        With .Paragraphs.First.Range
          xlRng.Offset(i, 4 + j) = .ListFormat.ListString & " " & .Text
        End With
      End With
      Do Until Split(wdRng.Paragraphs.First.Style, " ")(1) = 1
        wdRng.Start = wdRng.Start - 1
        Set wdRng = wdRng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
        With wdRng
          j = Split(.Paragraphs.First.Style, " ")(1)
          With .Paragraphs.First.Range
            xlRng.Offset(i, 4 + j) = .ListFormat.ListString & " " & .Text
          End With
        End With
      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

You can add more columns for data such as:

.Scope.Paragraphs(1).Range.Text
.Scope.Paragraphs(1).Range.ListFormat.ListString

and so on.

Upvotes: 2

Related Questions