0

以下代码来自“Word Hacks: Tips & Tools for Taming Your Text”，自动将所选文本交叉引用到任何具有相同内容的标题。我一直在尝试调整它以自动交叉引用具有相同内容的图形标题，但没有成功。这个想法是，如果用户在任何文本行中选择“图 3-5”（例如在显示“更多信息，请参阅图 3-5”的段落中），代码应该查找相应的图标题和自动插入对它的交叉引用。

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
4

1 回答 1

0

所以，我希望我能明白你的意思。老实说，使用insertCrossReference方法有点复杂，因为它有一个缺点 - 当设置它时，它会将您捕获引用的标题的整个“名称”放入所选范围。换句话说：如果你的标题是“图 1.2. 一月销售结果”，并且您希望“图 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查找您选择的文本并检查样式名称是否引用标题的功能。因此，您必须更改Headings 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。提出的想法的一个缺点是每个人都会crossreference创建新书签的情况。但从原始代码中摆脱“段落匹配和全名复制”是我唯一的想法。所以，我希望你明白我的意思，这会有所帮助。

于 2013-03-22T15:24:46.773 回答