Consulting

Results 1 to 2 of 2

Thread: InsertCrossReference from Bookmarks

  1. #1
    VBAX Newbie leonvl's Avatar
    Joined
    Mar 2019
    Location
    Netherlands
    Posts
    1
    Location

    InsertCrossReference from Bookmarks

    Looking for a snippet that can generate Cross-References from all Bookmarked Items within a document.
    Let's say I have a comprehensive document that contains 20 bookmarked words - then I would like the macro for each of them find the exact word within the document and create a cross reference to the bookmarked item. I thought this would be of much use to many of us, but can't find anything and have no clue where to start.

    Any help welcome...

    Sub CrossRefBookmark()Selection.InsertCrossReference ReferenceType:=wdRefTypeBookmark, _
    ReferenceKind:=wdContentText, ReferenceItem:=Trim(Selection.Text), _
    InsertAsHyperlink:=True
    End Sub
    Leon

  2. #2
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    The following macro generates a table of all bookmarks at the end of either the active document or a new document, plus another table of all references to those bookmarks, each table including details of the story range names, page & line numbers and contents:
    Sub ListBkMrksAndRefs()
    Application.ScreenUpdating = False
    Dim oBkMrk As Bookmark, StrBkMk As String, StrXREf As String, StrStory As String
    Dim wdDocIn As Document, wdDocOut As Document, Rng As Range, Fld As Field, bHid As Boolean, Dest
    Dest = MsgBox(Prompt:="Output to New Document? (Y/N)", Buttons:=vbYesNoCancel, Title:="Destination Selection")
    If Dest = vbCancel Then Exit Sub
    Set wdDocIn = ActiveDocument
    If Dest = vbYes Then Set wdDocOut = Documents.Add
    If Dest = vbNo Then Set wdDocOut = wdDocIn
    With wdDocIn
      bHid = .Bookmarks.ShowHidden
      .Bookmarks.ShowHidden = True
      If .Bookmarks.Count > 0 Then
        StrBkMk = vbCr & "Bookmark" & vbTab & "Page" & vbTab & "Line" & vbTab & "Story" & Chr(160) & "Range" & vbTab & "Contents"
        StrXREf = vbCr & "Bookmark Ref" & vbTab & "Page" & vbTab & "Line" & vbTab & "Story" & Chr(160) & "Range" & vbTab & "Type" & vbTab & "Text"
        For Each oBkMrk In .Bookmarks
          Select Case oBkMrk.StoryType
            Case 1: StrStory = "Main text"
            Case 2: StrStory = "Footnotes"
            Case 3: StrStory = "Endnotes"
            Case 4: StrStory = "Comments"
            Case 5: StrStory = "Text frame"
            Case 6: StrStory = "Even pages header"
            Case 7: StrStory = "Primary header"
            Case 8: StrStory = "Even pages footer"
            Case 9: StrStory = "Primary footer"
            Case 10: StrStory = "First page header"
            Case 11: StrStory = "First page footer"
            Case 12: StrStory = "Footnote separator"
            Case 13: StrStory = "Footnote continuation separator"
            Case 14: StrStory = "Footnote continuation notice"
            Case 15: StrStory = "Endnote separator"
            Case 16: StrStory = "Endnote continuation separator"
            Case 17: StrStory = "Endnote continuation notice"
            Case Else: StrStory = "Unknown"
          End Select
          StrBkMk = StrBkMk & vbCr & oBkMrk.Name & vbTab & _
            oBkMrk.Range.Characters.First.Information(wdActiveEndAdjustedPageNumber) & vbTab & _
            oBkMrk.Range.Information(wdFirstCharacterLineNumber) & vbTab & StrStory & vbTab & oBkMrk.Range.Text
        Next oBkMrk
        For Each Rng In .StoryRanges
          Select Case Rng.StoryType
            Case 1: StrStory = "Main text"
            Case 2: StrStory = "Footnotes"
            Case 3: StrStory = "Endnotes"
            Case 4: StrStory = "Comments"
            Case 5: StrStory = "Text frame"
            Case 6: StrStory = "Even pages header"
            Case 7: StrStory = "Primary header"
            Case 8: StrStory = "Even pages footer"
            Case 9: StrStory = "Primary footer"
            Case 10: StrStory = "First page header"
            Case 11: StrStory = "First page footer"
            Case 12: StrStory = "Footnote separator"
            Case 13: StrStory = "Footnote continuation separator"
            Case 14: StrStory = "Footnote continuation notice"
            Case 15: StrStory = "Endnote separator"
            Case 16: StrStory = "Endnote continuation separator"
            Case 17: StrStory = "Endnote continuation notice"
            Case Else: StrStory = "Unknown"
          End Select
          For Each Fld In Rng.Fields
            With Fld
              If (.Type = wdFieldRef) Then
                StrXREf = StrXREf & vbCr & Split(Trim(.Code.Text), " ")(1) & vbTab & _
                .Result.Characters.First.Information(wdActiveEndAdjustedPageNumber) & vbTab & _
                .Result.Information(wdFirstCharacterLineNumber) & vbTab & StrStory & vbTab & "Ref"
              ElseIf (.Type = wdFieldPageRef) Then
                StrXREf = StrXREf & vbCr & Split(Trim(.Code.Text), " ")(1) & vbTab & _
                .Result.Characters.First.Information(wdActiveEndAdjustedPageNumber) & vbTab & _
                .Result.Information(wdFirstCharacterLineNumber) & vbTab & StrStory & vbTab & "PageRef"
              End If
              StrXREf = StrXREf & vbTab & .Result
            End With
          Next
        Next
      Else
        MsgBox "There are no bookmarks in this document", vbExclamation
        GoTo Done
      End If
    End With
    With wdDocOut
      Set Rng = .Range.Characters.Last
      With Rng
        .Text = StrBkMk
        .Start = .Start + 1
        .ConvertToTable Separator:=vbTab
        With .Tables(1)
          .AutoFitBehavior wdAutoFitContent
          .Columns.Borders.Enable = True
          .Rows.Borders.Enable = True
          .Rows.First.Range.Font.Bold = True
        End With
      End With
      Set Rng = .Range.Characters.Last
      With Rng
        .Text = StrXREf
        .Start = .Start + 1
        .ConvertToTable Separator:=vbTab
        With .Tables(1)
          .AutoFitBehavior wdAutoFitContent
          .Columns.Borders.Enable = True
          .Rows.Borders.Enable = True
          .Rows.First.Range.Font.Bold = True
        End With
      End With
      .Bookmarks.ShowHidden = bHid
    End With
    Done:
    Set Rng = Nothing: Set wdDocIn = Nothing: Set wdDocOut = Nothing
    Application.ScreenUpdating = True
    End Sub
    Note that line numbers only apply to the main story. Other stories will return -1.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •