Word VBA - 如何插入标题编号的引用；标题文字；列出要评论的项目编号和列表项目页码？
Word VBA - How to insert references of heading number; heading text; list item number and list item page number to comment?
我想在我的 Word 文档中标记某些文本并添加带有各种参考的注释。
这样做是为了 a) 我可以 output/print 进一步处理评论中的那些细节，以及 b) 如果文档发展和更改，评论的信息也会更新。
我想在评论中包含的参考文献是：
- 文本（单个单词或句子等）所属的标题编号
- 标题文字
- 段落编号 -> 这是两列中第一列中的编号列表项 table 每个新标题重新开始（段落文本在右列）
- 段落的页码 -> 因此，列表项页码。
文本可能如下所示：
1.0 标题 A 文本
这是文档的第 1 页。
1.1 标题 B 文本
AB
no header actually
[1]
a text paragraph
[2]
another text paragraph
1.1.1 标题 C 文本
从这个标题开始第 2 页
AB
no header actually
[1]
a text paragraph
[2]
arbitrary paragraphs
2.0 标题 D 文本
AB
no header actually
[1]
a text paragraph
[2]
another text paragraph
2.1 标题 E 文本
2.1.1 标题 F 文本
AB
no header actually
[1]
a text paragraph
[2]
another text paragraph
如果为选定的 words/text 插入 MS Word 气球注释，则期望的结果是，如以下单词“任意”示例所示：
任意 ---->（第 1.1.1 节标题 C 文本；第 [2] 段；第 2 页）
我已经设法提取了大部分内容，即除了 paragraph/list 项目编号和段落页码（我现在使用的页码是标题的页码）之外的所有参考文献。
这是我目前拥有的：
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
我需要帮助的是如何识别和插入相应列表 item/paragraph 编号的引用到评论中？因此，换句话说，这将是：查看左侧的单元格，将指向列表 item/paragraph 编号的引用插入到注释（编号和页码）中，该编号可以在该单元格中找到。
正如您在示例中看到的那样，项目编号可以重复（在每个新标题处重新开始编号）并且它们没有标题那样的列表项目文本，因此我无法搜索该文本。
如有任何提示，我们将不胜感激。
请注意，我对 VBA 没有太多经验，以上是从许多其他问答主题中的各种其他示例中收集的。
非常感谢。
此致，
迈克尔.
您不需要在评论中存储任何数据以供以后提取。此外，此类存储的数据很可能会因评论创建和提取之间发生的编辑而失效。
以下宏将活动文档中的评论导出到新的 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
等等。
我想在我的 Word 文档中标记某些文本并添加带有各种参考的注释。 这样做是为了 a) 我可以 output/print 进一步处理评论中的那些细节，以及 b) 如果文档发展和更改，评论的信息也会更新。
我想在评论中包含的参考文献是：
- 文本（单个单词或句子等）所属的标题编号
- 标题文字
- 段落编号 -> 这是两列中第一列中的编号列表项 table 每个新标题重新开始（段落文本在右列）
- 段落的页码 -> 因此，列表项页码。
文本可能如下所示：
1.0 标题 A 文本
这是文档的第 1 页。
1.1 标题 B 文本
| AB | no header actually |
|---|---|
| [1] | a text paragraph |
| [2] | another text paragraph |
1.1.1 标题 C 文本
从这个标题开始第 2 页
| AB | no header actually |
|---|---|
| [1] | a text paragraph |
| [2] | arbitrary paragraphs |
2.0 标题 D 文本
| AB | no header actually |
|---|---|
| [1] | a text paragraph |
| [2] | another text paragraph |
2.1 标题 E 文本
2.1.1 标题 F 文本
| AB | no header actually |
|---|---|
| [1] | a text paragraph |
| [2] | another text paragraph |
如果为选定的 words/text 插入 MS Word 气球注释，则期望的结果是，如以下单词“任意”示例所示：
任意 ---->（第 1.1.1 节标题 C 文本；第 [2] 段；第 2 页）
我已经设法提取了大部分内容，即除了 paragraph/list 项目编号和段落页码（我现在使用的页码是标题的页码）之外的所有参考文献。
这是我目前拥有的：
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
我需要帮助的是如何识别和插入相应列表 item/paragraph 编号的引用到评论中？因此，换句话说，这将是：查看左侧的单元格，将指向列表 item/paragraph 编号的引用插入到注释（编号和页码）中，该编号可以在该单元格中找到。
正如您在示例中看到的那样，项目编号可以重复（在每个新标题处重新开始编号）并且它们没有标题那样的列表项目文本，因此我无法搜索该文本。
如有任何提示，我们将不胜感激。 请注意，我对 VBA 没有太多经验，以上是从许多其他问答主题中的各种其他示例中收集的。
非常感谢。
此致， 迈克尔.
您不需要在评论中存储任何数据以供以后提取。此外，此类存储的数据很可能会因评论创建和提取之间发生的编辑而失效。
以下宏将活动文档中的评论导出到新的 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
等等。