（注：解决方法见下文。）
我一直在尝试从使用 VBA 的 word 文档中的各种标题所在的页面中检索页码。我当前的代码返回 2 或 3，而不是正确关联的页码，具体取决于我在主 Sub 中使用它的位置和方式。
astrHeadings = docSource.GetCrossReferenceItems(wdRefTypeHeading)
For Each hds In astrHeadings
docSource.Activate
With Selection.Find
.Text = Trim$(hds)
.Forward = True
MsgBox hds & ":" & Selection.Information(wdActiveEndPageNumber), vbOKOnly
End With
Selection.Find.Execute
Next
docSource是我设置的一个测试文档，其中 10 个标题超过 3 页。我从getCrossReferenceItems稍后在我的代码中使用的方法中检索了标题。
我正在尝试遍历该getCrossReferenceItems方法的结果，并在 Find 对象中使用它们，docSource并由此确定结果在哪个页面上。然后在我的代码中稍后将在字符串中使用页码。这个字符串加上页码将被添加到在我的主子开头创建的另一个文档中，除此代码段外，其他所有内容都可以处理。
理想情况下，我需要这个段做的是用每个 Find 结果中的相关页码填充第二个数组。
解决的问题
谢谢凯文，你在这里提供了很大的帮助，我现在正是从 this 的输出中得到了我需要的东西Sub。
docSource 是一个测试文档，我设置了 10 个标题超过 3 页。docOutline 是一个新文档，它将充当目录文档。
我不得不Sub在 Word 的内置 TOC 功能上使用它，因为：
我有多个文档要包含，我可以使用该
RD字段来包含这些但是我有另一个
Sub在每个文档 0.0.0 （chapter.section.page 代表）中生成自定义十进制页码，为了使整个文档包有意义，需要将其作为页码包含在 TOC 中。可能还有另一种方法可以做到这一点，但我对 Word 的内置功能一无所知。
这将成为我的页码中包含的功能Sub。我目前完成这个小项目的 3/4，最后一个季度应该很简单。
修订和清理最终代码
Public Sub CreateOutline()
' from http://stackoverflow.com/questions/274814/getting-the-headings-from-a-word-document
Dim docOutline As Word.Document
Dim docSource As Word.Document
Dim rng As Word.Range
Dim strFootNum() As Integer
Dim astrHeadings As Variant
Dim strText As String
Dim intLevel As Integer
Dim intItem As Integer
Dim minLevel As Integer
Dim tabStops As Variant
Set docSource = ActiveDocument
Set docOutline = Documents.Add
minLevel = 5 'levels above this value won't be copied.
' Content returns only the
' main body of the document, not
' the headers and footer.
Set rng = docOutline.Content
astrHeadings = docSource.GetCrossReferenceItems(wdRefTypeHeading)
docSource.Select
ReDim strFootNum(0 To UBound(astrHeadings))
For i = 1 To UBound(astrHeadings)
With Selection.Find
.Text = Trim(astrHeadings(i))
.Wrap = wdFindContinue
End With
If Selection.Find.Execute = True Then
strFootNum(i) = Selection.Information(wdActiveEndPageNumber)
Else
MsgBox "No selection found", vbOKOnly
End If
Selection.Move
Next
docOutline.Select
With Selection.Paragraphs.tabStops
'.Add Position:=InchesToPoints(2), Alignment:=wdAlignTabLeft
.Add Position:=InchesToPoints(6), Alignment:=wdAlignTabRight, Leader:=wdTabLeaderDots
End With
For intItem = LBound(astrHeadings) To UBound(astrHeadings)
' Get the text and the level.
' strText = Trim$(astrHeadings(intItem))
intLevel = GetLevel(CStr(astrHeadings(intItem)))
' Test which heading is selected and indent accordingly
If intLevel <= minLevel Then
If intLevel = "1" Then
strText = " " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr
End If
If intLevel = "2" Then
strText = " " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr
End If
If intLevel = "3" Then
strText = " " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr
End If
If intLevel = "4" Then
strText = " " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr
End If
If intLevel = "5" Then
strText = " " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr
End If
' Add the text to the document.
rng.InsertAfter strText & vbLf
docOutline.SelectAllEditableRanges
' tab stop to set at 15.24 cm
'With Selection.Paragraphs.tabStops
' .Add Position:=InchesToPoints(6), _
' Leader:=wdTabLeaderDots, Alignment:=wdAlignTabRight
' .Add Position:=InchesToPoints(2), Alignment:=wdAlignTabCenter
'End With
rng.Collapse wdCollapseEnd
End If
Next intItem
End Sub
Private Function GetLevel(strItem As String) As Integer
' from http://stackoverflow.com/questions/274814/getting-the-headings-from-a-word-document
' Return the heading level of a header from the
' array returned by Word.
' The number of leading spaces indicates the
' outline level (2 spaces per level: H1 has
' 0 spaces, H2 has 2 spaces, H3 has 4 spaces.
Dim strTemp As String
Dim strOriginal As String
Dim intDiff As Integer
' Get rid of all trailing spaces.
strOriginal = RTrim$(strItem)
' Trim leading spaces, and then compare with
' the original.
strTemp = LTrim$(strOriginal)
' Subtract to find the number of
' leading spaces in the original string.
intDiff = Len(strOriginal) - Len(strTemp)
GetLevel = (intDiff / 2) + 1
End Function
此代码现在正在生成（根据我在 test-doc.docx 中找到的标题规范，它应该是什么）：
This is heading one 1.2.1
This is heading two 1.2.1
This is heading two.one 1.2.1
This is heading two.three 1.2.1
This is heading one.two 1.2.2
This is heading three 1.2.2
This is heading four 1.2.2
This is heading five 1.2.2
This is heading five.one 1.2.3
This is heading five.two 1.2.3
除此之外，我还通过使用and语句而不是 using解决了ActiveDocument切换问题 。docSource.selectdocOutline.Select.Active
再次感谢凯文，非常感谢:-)
菲尔