Additional text to hyperlink text does not extend the hyperlink style

[JPG]

Test file https://1drv.ms/u/s!AviK4OVgysDigfoUCr7Yq0Jaj5vgXw?e=xatcnV

Code below was adapted a little from that supplied on another forum by Macropod, whom I notice is in this forum also, so might be familiar with this code.
Attached is the test document. Basically this stage of markup of the file (which is processed by another app) I am trying to markup Bible chapter and verse numbers. The example shows just the chapter:verse. This needs a Book name which in this case I have set to Matthew in the code below. All you need to do to test is to select a couple of paragraphs in whole and run the code.

This with hyperlink text

22:4 (tw://bible.*/?id=40.22.4|_AUTODETECT_|). The king reiterates the honor of the invitation.
22:5 (tw://bible.*/?id=40.22.5|_AUTODETECT_|). Ignoring the king would be scandalously rude, .....
22:6 (tw://bible.*/?id=40.22.6|_AUTODETECT_|). This behavior would obviously have .....

becomes this. Which has not extended the hyperlink text to include Matthew

Matthew 22:4 (tw://bible.*/?id=40.22.4|_AUTODETECT_|). The king reiterates the honor of the invitation.
Matthew 22:5 (tw://bible.*/?id=40.22.5|_AUTODETECT_|). Ignoring the king would be scandalously rude, .....
Matthew 22:6 (tw://bible.*/?id=40.22.6|_AUTODETECT_|). This behavior would obviously have .....

The next stage that might be required in some cases is to markup this text, but the macro that is specifically designed for this part does not like the mixed, plain text and hypelink text.

So my question is, how to code this to "extend" the hyperlink text so it Includes Matthew.

Thanks to anyone who can help
Jon.




Sub testforforum()
Dim prefix As String


prefix = "Matthew" 'InputBox("Please enter the Bible book Name")
'If ComboBox1BibleBookName.text = "" Then
' MsgBox ("Please set a Bible book from the ComboBox")
' Exit Sub
'End If
'InSelection = False
'If selection.Type = wdSelectionIP Then InSelection = True
'
'If InSelection = True Then
'
' MsgBox ("select some text")
' Exit Sub
'End If
Application.ScreenUpdating = False
Dim RngFnd As Range, StrTxt As String


'If CheckBox3PrefixChVerseAnywhereInSelection.Value = False Then
'####################################


With selection
Set RngFnd = .Range
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.text = "[0-9]{1,3}:[0-9\-\–:]{1,9}"
.Replacement.text = ""
.Forward = True
.Format = False
.Wrap = wdFindStop
.MatchWildcards = True
'Required font size and color can be set here
.Font.Size = 10 'ComboBox2FontSize.Value
'.Font.Color = 12611584


.Execute
End With
Do While .Find.Found
If .InRange(RngFnd) Then
If .Paragraphs.Count > 1 Then .Start = .Paragraphs(1).Range.End
If .Start = .Paragraphs(1).Range.Start Then
.Font.Size = ComboBox2FontSize.Value
StrTxt = .text
.InsertBefore prefix & " "


'If CheckBox4Bold.Value = True Then
.Font.Bold = True
' End If
'If CheckBox5Blue.Value = True Then
.Font.ColorIndex = wdBlue
'End If
.Start = .End - Len(StrTxt)
End If
If .Hyperlinks.Count > 0 Then
If .Hyperlinks(1).Range.Start = .Paragraphs(1).Range.Start Then
With .Hyperlinks(1).Range
.Font.Size = 10 'ComboBox2FontSize.Value
StrTxt = .text
.InsertBefore prefix & " "


'If CheckBox4Bold.Value = True Then
.Font.Bold = True
'End If
'If CheckBox5Blue.Value = True Then
.Font.ColorIndex = wdBlue
'End If
.Start = .End - Len(StrTxt) - 1
End With
End If
End If
Else
Exit Do
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
RngFnd.Select
Application.ScreenUpdating = True
selection.Find.ClearFormatting
selection.Find.Replacement.ClearFormatting
End Sub

[gmayor]

Maybe the following will help

Sub Macro1()
'Graham Mayor - https://www.gmayor.com - Last updated - 10 Mar 2020
Dim oPara As Paragraph
Dim hLink As Hyperlink
Dim sText As String
Dim sPrefix As String
sPrefix = InputBox("Enter the book name", , "Matthew")
For Each oPara In Selection.Paragraphs
If oPara.Range.Hyperlinks.Count > 0 Then
Set hLink = oPara.Range.Hyperlinks(1)
If hLink.Range.Start = oPara.Range.Start Then
sText = hLink.TextToDisplay
If Not sPrefix = "" Then
hLink.TextToDisplay = sPrefix & Chr(32) & sText
End If
End If
End If
Next oPara
lbl_Exit:
Set oPara = Nothing
Set hLink = Nothing
Exit Sub
End Sub

[JPG]

ok thanks for the response. However I do need to constrain what it will be applied to as per the
.text = "[0-9]{1,3}:[0-9\-\–:]{1,9}"
So is there no way to tweak the code I posted? because those are the constraints needed.
I have other code options that deal with text in the main body that does not have a book name. I do use a more liberal approach to that in so much as it does not have to be at the start of the pargraph. Actually the optional code will work on the example document but I only allow one paragraph at a time to be selected. So it all comes back to my original code and requirement.

[JPG]

I decided to cut out the intermediate stage of marking up the text with a prefix and put it as an option. Here is the code. Any comments appreciated. Although it does not extend the hyperlink to be active on the prepended text it will be fine, unless anyone has a fix for that.

Thanks for all the assistance that guided me to a solution.
Jon


Private Sub CommandButtonRelRefNoBibleName_Click()
Dim prefix As String
prefix = ComboBox1BibleBookName.text 'InputBox("Please enter the Bible book Name")
If ComboBox1BibleBookName.text = "" Then
MsgBox ("Please set a Bible book from the ComboBox")
Exit Sub
End If
InSelection = False
If selection.Type = wdSelectionIP Then InSelection = True

If InSelection = True Then

MsgBox ("select some text")
Exit Sub
End If
Application.ScreenUpdating = False
Dim RngFnd As Range, StrTxt As String
With selection
Set RngFnd = .Range
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.text = "[0-9]{1,3}:[0-9\-\–:]{1,9}"
.Replacement.text = ""
.Forward = True
.Format = False
.Wrap = wdFindStop
.MatchWildcards = True
'Required font size and color can be set here
.Font.Size = ComboBox2FontSize.Value
'.Font.Color = 12611584


.Execute
End With
Do While .Find.Found
If .InRange(RngFnd) Then
If .Paragraphs.Count > 1 Then .Start = .Paragraphs(1).Range.End
If .Start = .Paragraphs(1).Range.Start Then
StrTxt = .text
If CheckBox6Bold.Value = True Then
.Font.Bold = True
End If
If CheckBox7Blue.Value = True Then
.Font.ColorIndex = wdBlue
End If

If CheckBox8AddBibleBookAsPrefix.Value = False Then
.InsertBefore "<ref>" & prefix & " " & StrTxt & "</ref>"
End If
If CheckBox8AddBibleBookAsPrefix.Value = True Then
.InsertBefore "<ref>" & prefix & " " & StrTxt & "</ref>" & prefix & Chr(32)
End If
.Start = .End - Len(StrTxt)
End If
If .Hyperlinks.Count > 0 Then
If .Hyperlinks(1).Range.Start = .Paragraphs(1).Range.Start Then
With .Hyperlinks(1).Range
StrTxt = .text
If CheckBox6Bold.Value = True Then
.Font.Bold = True
End If
If CheckBox7Blue.Value = True Then
.Font.ColorIndex = wdBlue
End If
If CheckBox8AddBibleBookAsPrefix.Value = False Then
.InsertBefore "<ref>" & prefix & " " & StrTxt & "</ref>"
End If
If CheckBox8AddBibleBookAsPrefix.Value = True Then
.InsertBefore "<ref>" & prefix & " " & StrTxt & "</ref>" & prefix & Chr(32)
End If
.Start = .End - Len(StrTxt) - 1
End With
End If
End If
Else
Exit Do
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
RngFnd.Select
Application.ScreenUpdating = True
selection.Find.ClearFormatting
selection.Find.Replacement.ClearFormatting
end sub

[gmayor]

Try the following instead

Sub Macro1()
'Graham Mayor - https://www.gmayor.com - Last updated - 11 Mar 2020
Dim oPara As Paragraph
Dim hLink As Hyperlink
Dim sText As String
Dim sPrefix As String
sPrefix = InputBox("Enter the book name", , "Matthew")
For Each oPara In Selection.Paragraphs
If oPara.Range.Hyperlinks.Count > 0 Then
For Each hLink In oPara.Range.Hyperlinks
sText = hLink.TextToDisplay
If InStr(1, sText, sPrefix) = 0 And IsNumeric(Left(sText, 1)) = True Then
If Not sPrefix = "" Then
hLink.TextToDisplay = sPrefix & Chr(32) & sText
End If
End If
Next hLink
End If
Next oPara
lbl_Exit:
Set oPara = Nothing
Set hLink = Nothing
Exit Sub
End Sub

[JPG]

Thank you I will add this to my macro tools repertoire.