时间戳

首页 > 解决方案 > Word VBA - 如何插入标题编号的引用；标题文字；要评论的列表项编号和列表项页码？

vba - Word VBA - 如何插入标题编号的引用；标题文字；要评论的列表项编号和列表项页码？

问题描述

我想在我的 Word 文档中标记某些文本并添加带有各种参考的注释。这样一来，a) 我可以在评论中输出/打印这些详细信息以供进一步处理；b) 如果文档发生变化，评论的信息会得到更新。

我想在评论中包含的参考资料是：

文本可能如下所示：

1.0 标题文本

这是文档的第 1 页。

1.1 标题 B 文字

AB 实际上没有标题
[1] 文本段落
[2] 另一个文本段落

1.1.1 标题 C 文本

从这个标题第 2 页开始

AB 实际上没有标题
[1] 文本段落
[2] 任意段落

2.0 标题 D 文本

AB 实际上没有标题
[1] 文本段落
[2] 另一个文本段落

2.1 标题 E 文本

2.1.1 标题 F 文本

AB 实际上没有标题
[1] 文本段落
[2] 另一个文本段落

期望的结果是，如果为选定的单词/文本插入 MS Word 气球注释，如下例中的“任意”一词：

任意---->（第 1.1.1 节标题 C 文本；第 [2] 段；第 2 页）

我已经设法提取了大部分内容，即除段落/列表项编号和段落页码（对于我现在使用的页码标题的页码）之外的所有引用。

这是我到目前为止所拥有的：

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

我需要帮助的是如何识别相应列表项/段落编号的引用并将其插入评论中？因此，换句话说，这将是这样的：查看左侧的单元格，将指向可以在该单元格中找到的列表项/段落编号的引用插入到注释中（编号和页码）。

正如您在示例中看到的那样，项目编号可以重复（在每个新标题处重新编号），并且它们没有标题那样的列表项文本，因此我无法搜索该文本。

任何提示将不胜感激。请注意，我对 VBA 没有太多经验，以上内容是从许多其他问答线程中的各种其他示例中收集的。

非常感谢。

最好的问候，迈克尔。

标签： vbams-wordcross-reference

解决方案

您无需将任何数据存储在注释中以供以后提取。此外，这种存储的数据很可能会因评论创建和提取之间发生的编辑而失效。

以下宏将活动文档中的注释以及与注释关联的任何标题一起导出到新的 Excel 工作簿，以标题级别顺序在同一行的不同列中。

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

您可以为数据添加更多列，例如：

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

等等。

推荐阅读