Thread: [Solved] Place Hyperlink text inline
View Single Post
Old 11-12-2022, 07:16 PM
BrianHoard BrianHoard is offline Windows 10 Office 2019
Advanced Beginner
Join Date: Jul 2022
Location: Haymarket, VA USA
Posts: 81
BrianHoard is on a distinguished road

Hi, this was a fun one.
I'm still learning VBA, so this could very likely be improved upon, but in my test, it resulted in exactly what you listed as your end goal.

Some areas that might need changed based on your documents:
  • This script is written specifically for your test document. It would likely have problems in you have hyperlinks that are not bookmarks in your doc.
  • I'm not doing any error checking to ensure you have some bookmarks to start with.
  • This is a first pass at the problem, so very likely areas could be optimized and improved.
Sub bhh_inlineBookmarks()
  ' Written by Brian Hoard,

  Dim scriptName As String
  scriptName = "bhh_inlineBookmarks"
  Application.ScreenUpdating = False
  ' Begin undo record
  Dim bhhUndo As UndoRecord
  Set bhhUndo = Application.UndoRecord
  bhhUndo.StartCustomRecord (scriptName)

  Dim f As Field
  Dim rngSource As Range
  Dim rng_bm As Range
  Dim i As Integer
  i = 1 ' Begin hyperlink counter
  For Each f In ActiveDocument.Fields
    If f.Type = wdFieldHyperlink Then
      Set rngSource = Selection.Range
      f.Delete ' Delete the link
      ' Define the range in the document body where the bookmark is at.
      With rngSource
        .Font.Superscript = False
      End With
      ' Process the linked text.
      ' NOTE: This is subject to problems if the document includes hyperlinks that are not bookmarks.
      Set rng_bm = ActiveDocument.Bookmarks.Item(i).Range

      With rng_bm
        .Expand wdParagraph ' Expand the range to the full paragraph
        .End = .End - 1 ' Bring range End to the left 1 character to exclude the carriage return.
      End With

      rngSource.Text = (" [" & rng_bm.Text & "]")

    End If ' /f.Type = wdFieldHyperlink

    i = (i + 1) ' increment bookmark counter

  Next f

  ' End undo
  Application.ScreenUpdating = True

End Sub
Reply With Quote