Consulting

Results 1 to 6 of 6

Thread: Additional text to hyperlink text does not extend the hyperlink style

  1. #1
    VBAX Regular
    Joined
    Mar 2020
    Posts
    79
    Location

    Additional text to hyperlink text does not extend the hyperlink style

    Test file https://1drv.ms/u/s!AviK4OVgysDigfoU...5vgXw?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
    . The king reiterates the honor of the invitation.
    22:5. Ignoring the king would be scandalously rude, .....
    22:6. This behavior would obviously have .....

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

    Matthew 22:4. The king reiterates the honor of the invitation.
    Matthew 22:5. Ignoring the king would be scandalously rude, .....
    Matthew 22:6. 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

  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Regular
    Joined
    Mar 2020
    Posts
    79
    Location
    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.

  4. #4
    VBAX Regular
    Joined
    Mar 2020
    Posts
    79
    Location
    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

  5. #5
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  6. #6
    VBAX Regular
    Joined
    Mar 2020
    Posts
    79
    Location
    Thank you I will add this to my macro tools repertoire.

Posting Permissions

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