VBA Word. Get the color number of the highlight, of the highlighted text

The code below works like a charm. It lists the highlighted text in a String.
What I would like to ask though, is to modify this code a bit so I get the number of the highlight color next to each string catch.  

Option Explicit

Sub CollectHighlights()
    Dim rng As Range
    Dim strText As String
    
    Set rng = ActiveDocument.Range
    Do
        With rng.Find
            .Highlight = True
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            If .Execute Then
                strText = strText & rng.Text & vbCr
                rng.Collapse wdCollapseEnd
                rng.End = ActiveDocument.Range.End
            Else
                Exit Do
            End If
        End With
    Loop While True
    MsgBox strText
End Sub

Open in new window


Thank you with love again as always.

I give full 250 points with an A classification for this.
LVL 1
New_AlexAsked:
Who is Participating?
 
Chris BottomleyConnect With a Mentor Software Quality Lead EngineerCommented:
Apologies ... color number is of course simply:

Chris
Sub CollectHighlights()
    Dim rng As Range
    Dim strText As String
    
    Set rng = ActiveDocument.Range
    Do
        With rng.Find
            .Highlight = True
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            If .Execute Then
                strText = strText & rng.Text & ", (" & rng.HighlightColorIndex & ")" & vbCr
                rng.Collapse wdCollapseEnd
                rng.End = ActiveDocument.Range.End
            Else
                Exit Do
            End If
        End With
    Loop While True
    MsgBox strText
End Sub

Open in new window

0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
See below.

Chris
Sub CollectHighlights()
    Dim rng As Range
    Dim strText As String
    
    Set rng = ActiveDocument.Range
    Do
        With rng.Find
            .Highlight = True
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            If .Execute Then
                strText = strText & rng.Text & ", (" & strwdColorIndex(rng.HighlightColorIndex) & ")" & vbCr
                rng.Collapse wdCollapseEnd
                rng.End = ActiveDocument.Range.End
            Else
                Exit Do
            End If
        End With
    Loop While True
    MsgBox strText
End Sub

Function strwdColorIndex(index As Integer) As String
    Select Case index
        Case -1
            strwdColorIndex = "wdByAuthor"
        Case 0
            strwdColorIndex = "wdAuto - No Highlight"
        Case 1
            strwdColorIndex = "Black"
        Case 2
            strwdColorIndex = "Blue"
        Case 3
            strwdColorIndex = "Turquoise"
        Case 4
            strwdColorIndex = "Bright Green"
        Case 5
            strwdColorIndex = "Pink"
        Case 6
            strwdColorIndex = "Red"
        Case 7
            strwdColorIndex = "Yellow"
        Case 8
            strwdColorIndex = "White"
        Case 9
            strwdColorIndex = "Dark Blue"
        Case 10
            strwdColorIndex = "Teal"
        Case 11
            strwdColorIndex = "Green"
        Case 12
            strwdColorIndex = "Violet"
        Case 13
            strwdColorIndex = "Dark Red"
        Case 14
            strwdColorIndex = "Dark Yellow"
        Case 15
            strwdColorIndex = "Grey 50%"
        Case 16
            strwdColorIndex = "Grey 25%"
        Case Else
            strwdColorIndex = "Error!"
    End Select
        
End Function

Open in new window

0
 
New_AlexAuthor Commented:
Chris thanks very much,

I love you brother, like always....

Promised points given straight away.....
0
 
New_AlexAuthor Commented:
I have modified the code a bit. I inactivated the 2 lines :
 '   rng.Collapse wdCollapseEnd
              '  rng.End = ActiveDocument.Range.End
As they cause some crashes and other problems.
It works better now. (Code below)

[code]Option Explicit

Sub CollectHighlights()
    Dim rng As Range
    Dim strText As String
   
    Set rng = ActiveDocument.Range
    Do
        With rng.Find
            .Highlight = True
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            If .Execute Then
                  strText = strText & "Color Index " & rng.HighlightColorIndex _
                                    & "  : " & rng.Text & vbCr
                '   rng.Collapse wdCollapseEnd
              '  rng.End = ActiveDocument.Range.End
            Else
                Exit Do
            End If
        End With
    Loop While True
    MsgBox strText
End Sub

[/code]

Thanks!!!!
0
 
GrahamSkanRetiredCommented:
The two lines shouldn't give a problem. They are designed to explicitly search from the end of the current highlight to the end of the document.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.