Thread: [Solved] Place Hyperlink text inline
View Single Post
Old 11-13-2022, 04:51 AM
Italophile Italophile is offline Windows 11 Office 2021
Competent Performer
Join Date: Mar 2022
Posts: 103
Italophile is on a distinguished road

The following code will process the hyperlinks and the referenced bookmarked locations in the same document. The hyperlinks are replaced with the text from the bookmark and will retain the formatting of that text.

Sub MoveHyperlinkedText()
    Dim hlIdx As Long, hlink As Hyperlink, hlRng As Range
    Dim bmName As String, bmRng As Range
    If ActiveDocument.Hyperlinks.Count > 0 And ActiveDocument.Bookmarks.Count > 0 Then
        Application.ScreenUpdating = False
        'because hyperlinks will be deleted it is necessary to process them in reverse order
        For hlIdx = ActiveDocument.Hyperlinks.Count To 1 Step -1
            Set hlink = ActiveDocument.Hyperlinks(hlIdx)
            If hlink.Type = msoHyperlinkRange Then  'ignore any hyperlinked shapes
                If hlink.Address = vbNullString Then
                    'it's a link to a location in the same document so ensure that it exists
                    bmName = hlink.SubAddress
                    If ActiveDocument.Bookmarks.Exists(bmName) Then
                        'get range of bookmarked paragraph, minus the paragraph mark
                        Set bmRng = ActiveDocument.Bookmarks(bmName).Range
                        With bmRng
                            .Expand wdParagraph
                            .End = .End - 1
                        End With
                        Set hlRng = hlink.Range
                        With hlRng
                            'turn off superscript and replace text with brackets
                            .Font.Superscript = False
                            .Text = " []"
                            .Start = .Start + 2
                            .End = .End - 1
                            'add the bookmarked text and its formatting
                            .FormattedText = bmRng.FormattedText
                        End With
                    End If
                End If
            End If
        Next hlIdx
        Application.ScreenUpdating = True
    End If

End Sub
Reply With Quote