Link to home
Start Free TrialLog in
Avatar of New_Alex
New_AlexFlag for Cyprus

asked on

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.
Avatar of Chris Bottomley
Chris Bottomley
Flag of United Kingdom of Great Britain and Northern Ireland image

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

ASKER CERTIFIED SOLUTION
Avatar of Chris Bottomley
Chris Bottomley
Flag of United Kingdom of Great Britain and Northern Ireland image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of New_Alex

ASKER

Chris thanks very much,

I love you brother, like always....

Promised points given straight away.....
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!!!!
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.