在Word 2007中制作自动参考图来显示标题？

Question

以下代码来自“Word Hacks:Tips”

Sub MakeAutoXRef() 
    Dim sel As Selection 
    Dim rng As range 
    Dim para As Paragraph 
    Dim doc As Document 
    Dim sBookmarkName As String 
    Dim sSelectionText As String 
    Dim lSelectedParaIndex As Long 
    Set sel = Selection 
    Set doc = sel.Document 
    If sel.range.Paragraphs.Count <> 1 Then Exit Sub 
    lSelectedParaIndex = GetParagraphIndex(sel.range.Paragraphs.First) 
    sel.MoveStartWhile cset:=(Chr$(32) & Chr$(13)), Count:=sel.Characters.Count 
    sel.MoveEndWhile cset:=(Chr$(32) & Chr$(13)), Count:=-sel.Characters.Count 
    sSelectionText = sel.text 
    For Each para In doc.Paragraphs 
        Set rng = para.range 
        rng.MoveStartWhile cset:=(Chr$(32) & Chr$(13)), _ 
        Count:=rng.Characters.Count 
        rng.MoveEndWhile cset:=(Chr$(32) & Chr$(13)), _ 
        Count:=-rng.Characters.Count 
        If rng.text = sSelectionText Then 
            If Not GetParagraphIndex(para) = lSelectedParaIndex Then 
                sBookmarkName = GetOrSetXRefBookmark(para) 
                If Len(sBookmarkName) = 0 Then 
                    MsgBox "Couldn't get or set bookmark" 
                    Exit Sub 
                End If 
                sel.InsertCrossReference _ 
                referencekind:=wdContentText, _ 
                referenceItem:=doc.Bookmarks(sBookmarkName), _ 
                referencetype:=wdRefTypeBookmark, _ 
                insertashyperlink:=True 
                Exit Sub 
            Else 
                MsgBox "Can't self reference!" 
            End If 
        End If 
    Next para 
End Sub 


Function RemoveInvalidBookmarkCharsFromString(ByVal str As String) As String 
    Dim i As Integer 
    For i = 33 To 255 
        Select Case i 
        Case 33 To 47, 58 To 64, 91 To 96, 123 To 255 
            str = Replace(str, Chr(i), vbNullString) 
        End Select 
    Next i 
    RemoveInvalidBookmarkCharsFromString = str 
End Function


Function ConvertStringRefBookmarkName(ByVal str As String) As String 
    str = RemoveInvalidBookmarkCharsFromString(str) 
    str = Replace(str, Chr$(32), "_") 
    str = "_" & str 
    str = "XREF" & CStr(Int(90000 * Rnd + 10000)) & str 
    ConvertStringRefBookmarkName = str 
End Function 


Function GetParagraphIndex(para As Paragraph) As Long 
    GetParagraphIndex = _ 
    para.range.Document.range(0, para.range.End).Paragraphs.Count 
End Function 


Function GetOrSetXRefBookmark(para As Paragraph) As String 
    Dim i As Integer 
    Dim rng As range 
    Dim sBookmarkName As String 
    If para.range.Bookmarks.Count <> 0 Then 
        For i = 1 To para.range.Bookmarks.Count 
            If InStr(1, para.range.Bookmarks(i).name, "XREF") Then 
                GetOrSetXRefBookmark = para.range.Bookmarks(i).name 
                Exit Function 
            End If 
        Next i 
    End If 
    Set rng = para.range 
    rng.MoveEnd unit:=wdCharacter, Count:=-1 
    sBookmarkName = ConvertStringRefBookmarkName(rng.text) 
    para.range.Document.Bookmarks.Add _ 
    name:=sBookmarkName, _ 
    range:=rng 
    GetOrSetXRefBookmark = sBookmarkName 
End Function

Answer 1

所以，我希望我明白你的意思。老实说，使用insertCrossReference方法有点复杂，因为它有一个缺点——当设置为时，它会将捕获引用的标题的整个“名称”放入选定范围。换句话说：如果你的标题是“图1.2”。“1月销售结果”，您希望“图1.2”与标题链接，它会将您的“图1.2”替换为较长的原始标题。因此，您提出的基本思想保留了段落引用。但是，我做了一些尝试，并提出以下建议：a）将以下代码放入模块，而不是MakeAutoXRef子例程：

Sub findToReference()

Dim whatTo As Range
Set whatTo = Selection.Range

Dim whatToTxt As String
    whatToTxt = whatTo.text
Dim sBookmarkName As String

Dim rngDoc As Range
Set rngDoc = ActiveDocument.Content

With rngDoc.find
    .text = whatTo
    .Style = "Headings 1"   'place name of style here, like 'Headings 1' or something
    .Execute
End With

If rngDoc.find.Found = True Then
    'rngDoc.Select     'selection what was fount
    'found text to bookmark
    sBookmarkName = GetOrSetXRefBookmark(rngDoc)
    'copy from previous
     If Len(sBookmarkName) = 0 Then
                MsgBox "Couldn't get or set bookmark"
                Exit Sub
    End If

    whatTo.InsertCrossReference _
                referencetype:=wdRefTypeBookmark, _
                referencekind:=wdContentText, _
                referenceItem:=rngDoc.Bookmarks(sBookmarkName), _
                insertashyperlink:=True
 Else
    MsgBox "No headers matching selection found!"

End If
End Sub

一些评论：我建议使用find功能查找您选择的文本，并检查样式名称是否引用标题。因此，您必须将标题1更改为适当的样式名称。另一点是，第一次出现将匹配并设置对所选文本的引用。

此外，您需要更改一个函数。将原来的GetOrSetXRefBookmark函数替换为下面的函数。

Function GetOrSetXRefBookmark(paraRng As Range) As String
Dim i As Integer
Dim rng As Range
Dim sBookmarkName As String
   sBookmarkName = ConvertStringRefBookmarkName(paraRng.text)
   paraRng.Bookmarks.Add _
      Name:=sBookmarkName, _
      Range:=paraRng
GetOrSetXRefBookmark = sBookmarkName
End Function

它适用于Word 2010。提出的想法的一个缺点是情况，即每个交叉引用创建新的书签。但我唯一的想法是从原始代码中摆脱“段落匹配和全名复制”。所以，我希望你明白我的意思，这将是有帮助的。