Sub URLlauncher()
' Paul Beverley - Version 14.01.21
' Launches successive URLs from the text

numberOfURLs = 10

highlightURL = True
myHighlight = wdGray25

acceptableChars = "/a-zA-Z0-9.,;:=&#\?\(\)\[\]_+\-%" _
     & ChrW(8211) & ChrW(8212)
If Selection.Start = Selection.End Then
  numberOfURLs = 1
  Selection.Expand wdWord
  Selection.Collapse wdCollapseStart
Else
  myInput = InputBox("How many?", "URL launcher", _
       Trim(Str(numberOfURLs)))
  numberOfURLs = Val(myInput)
  If numberOfURLs = 0 Then Exit Sub
  Selection.Collapse wdCollapseEnd
End If

hereNow = Selection.End
linksTotal = ActiveDocument.Hyperlinks.Count
If linksTotal > 0 Then
  Set rng = ActiveDocument.Content
  Documents.Add
  Selection.FormattedText = rng.FormattedText
  Selection.End = hereNow
  Selection.Start = 0
  Selection.Delete
  linksTotal = ActiveDocument.Hyperlinks.Count
  If linksTotal > 0 Then
    For i = 1 To linksTotal
      Set hy = ActiveDocument.Hyperlinks(i)
      myURL = ActiveDocument.Hyperlinks(i).Address
      hy.Range.Select
      Selection.Font.Superscript = False
      URLtext = Selection.Text
      Selection.Collapse wdCollapseEnd
      If myURL <> URLtext Then
        Selection.TypeText "  " & myURL & "  "
      End If
    Next i
  End If
  ActiveDocument.Fields.Unlink
  Selection.HomeKey Unit:=wdStory
  Beep
End If

nowColour = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = myHighlight
On Error GoTo ReportIt

myFind = "[hpstw]{3,5}:[" & acceptableChars & "]{1,}"
With Selection.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = myFind
  .Wrap = False
  .Forward = True
  .MatchWildcards = True
  .Execute
End With
Selection.Collapse wdCollapseStart
i = 0
Do While i < numberOfURLs And Selection.Find.Found
  i = i + 1
  Selection.Find.Execute
  Do While InStr(".,", Right(Selection.Text, 1)) > 0
    Selection.MoveEnd , -1
    DoEvents
  Loop
  myURL = Selection
  If Left(myURL, 4) = "www." Then
    myURL = "http://" & myURL
  End If
  ActiveDocument.FollowHyperlink Address:=myURL
  Selection.Collapse wdCollapseEnd
  If highlightURL Then
    Selection.Range.HighlightColorIndex = myHighlight
  End If
  Selection.Collapse wdCollapseEnd
Loop
Options.DefaultHighlightColorIndex = nowColour
If numberOfURLs > 2 Then Beep
Exit Sub

ReportIt:
If Err.Number = 4198 Then
  MsgBox ("URL not found: " & vbCr & vbCr & myURL)
Else
  On Error GoTo 0
  Resume
End If
End Sub