Question

以下代码来自“Word Hacks：驯服文本的提示和工具”，自动将所选文本交叉引用到具有相同内容的任何标题。我一直试图调整它以自动交叉引用具有相同内容的图形标题，但没有成功。这个想法是，如果用户在任何文本行中选择“图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

Answer 1

所以，我希望我明白你的观点。说实话，使用insertCrossReference方法有点复杂，因为它有一个缺点 - 当设置它时，它会将你所引用的标题的整个'name'放入所选范围。换句话说：如果你的标题是'图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功能查找您选择的文本并检查样式名称是否指标题。因此，您必须将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创建新书签的情况。但是我唯一的想法是从原始代码中删除“段落匹配和全名复制”。所以，我希望你明白我的观点，这会有所帮助。

使autoXrefs能够在Word 2007中显示字幕？

1 个答案: