Microsoft Office Forums - View Single Post - [Solved] use hyperlink in page number in index

macropod · 07-27-2017, 03:18 PM

Indexes in Word don't support hyperlinks, for the simple reason that a given index entry could potentially reference multiple XE fields on the same page, or to XE fields spanning a range of pages; a hyperlink can only go to one such entry and, given that your document's pagination might change if you change the active printer driver, margins, etc., there is no way for Word to know beforehand which item to link to.

The following macro converts a Word Index to a hyperlinked form, where each hyperlink points to the first corresponding index entry on each explicitly-referenced indexed page.

One consequence of this approach is that the Index will no longer update, so its use would ideally be restricted to documents whose editing has been completed and are not to be viewed on systems using different printer drivers than the one on which the macro is run. That said, if you make edits to the document that change the pages on which the indexed entries occur, simply re-run the macro and the entries will be updated.

Code:

Sub IndexHyperlinker()
' Sourced from: https://www.msofficeforums.com/word/36257-use-hyperlink-page-number-index.html
Application.ScreenUpdating = False
Dim Fld As Field, Rng As Range, StrIdx As String, StrList As String, IdxTxt As String, i As Long, j As Long
StrList = vbCr
With ActiveDocument
  If .Indexes.Count = 0 Then
    If (.Bookmarks.Exists("_INDEX") = False) Or (.Bookmarks.Exists("_IdxRng") = False) Then
      MsgBox "No Index found in this document", vbExclamation: Exit Sub
    End If
  End If
  .Fields.Update
  For Each Fld In .Fields
    With Fld
      Select Case .Type
        Case wdFieldIndexEntry
          StrIdx = Trim(Replace(Replace(Split(.Code.Text, "XE ")(1), ", ", "_"), Chr(34), ""))
          If InStr(StrList, vbCr & StrIdx & ",") = 0 Then
            i = 0: StrList = StrList & StrIdx & "," & i & vbCr
          Else
            i = Split(Split(StrList, vbCr & StrIdx & ",")(1), vbCr)(0)
          End If
          StrList = Replace(StrList, StrIdx & "," & i & vbCr, StrIdx & "," & i + 1 & vbCr)
          i = i + 1: Set Rng = .Code
          With Rng
            .Start = .Start - 1: .End = .End + 1
            .Bookmarks.Add Name:=StrIdx & i, Range:=.Duplicate
          End With
        Case wdFieldIndex: IdxTxt = "SET _" & Fld.Code
        Case wdFieldSet: IdxTxt = Split(Fld.Code, "_")(1)
      End Select
    End With
  Next
  If (.Bookmarks.Exists("_INDEX") = True) And (.Bookmarks.Exists("_IdxRng") = True) Then _
    .Fields.Add Range:=.Bookmarks("_IdxRng").Range, Type:=wdFieldEmpty, Text:=IdxTxt, Preserveformatting:=False
  Set Rng = .Indexes(1).Range
  With Rng
    IdxTxt = "SET _" & Trim(.Fields(1).Code)
    .Fields(1).Unlink
    If Asc(.Characters.First) = 12 Then .Start = .Start + 1
    For i = 1 To .Paragraphs.Count
      With .Paragraphs(i).Range
        StrIdx = Replace(Split(Split(.Text, vbTab)(0), vbCr)(0), ", ", " ")
        .MoveStartUntil vbTab, wdForward: .Start = .Start + 1: .End = .End - 1
        For j = 1 To .Words.Count
          If IsNumeric(Trim(.Words(j).Text)) Then
            .Hyperlinks.Add Anchor:=.Words(j), SubAddress:=GetBkMk(Trim(.Words(j).Text), StrIdx), TextToDisplay:=.Words(j).Text
          End If
        Next
      End With
    Next
    .Start = .Start - 1: .End = .End + 1: .Bookmarks.Add Name:="_IdxRng", Range:=.Duplicate
    .Collapse wdCollapseStart: .Fields.Add Range:=Rng, Type:=wdFieldEmpty, Text:=IdxTxt, Preserveformatting:=False
  End With
End With
Application.ScreenUpdating = True
End Sub

Function GetBkMk(j As Long, StrIdx As String) As String
Dim i As Long: GetBkMk = "Error!"
With ActiveDocument
  For i = 1 To .Bookmarks.Count
    If InStr(.Bookmarks(i).Name, StrIdx) = 1 Then
      If .Bookmarks(i).Range.Information(wdActiveEndAdjustedPageNumber) = j Then _
        GetBkMk = .Bookmarks(i).Name: Exit For
    End If
  Next
End With
End Function

For PC macro installation & usage instructions, see: Installing Macros
For Mac macro installation & usage instructions, see: Word:mac - Install a Macro