macropod:
I finally had a chance to thoroughly test your code (after being distracted for a month) and found that it listed 19 shaded regions, just as you said. However, there are 27 shaded regions in the test.docx I posted in this thread.
I learned a lot from your code, but I still don't understand Word VBA enough to figure out what was wrong. So, instead I modified your code in a way I could understand. You'll see that your code is still there, but commented out. This modified code gets all 27 shaded regions, but I found that preceding superscripts would cause a 1-character shift in the highlighted range. I added an if statement to fix this (but I really don't understand it). Oh, and I also commented out a part of your code at the bottom that didn't seem to apply -- I think it has to do with tables?
I'm sure my code could be improved. If you have any more pointers I'd be glad to hear.
Thanks again
Code:
Sub Demo_modified()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, Rng As Range, count As Integer
count = 1
With ActiveDocument.Range
With .Find
.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Execute Replace:=wdReplaceAll
.Wrap = wdFindStop
.Font.Shading.BackgroundPatternColor = wdColorAutomatic
End With
Do While .Find.Execute
i = .Start: Set Rng = ActiveDocument.Range(j, .Start)
With Rng.Font.Shading
Select Case .BackgroundPatternColor
Case wdColorAutomatic
Case wdColorWhite
'my inserted code:
Case 9999999 'ie, mix of shade colors
Dim shdColor As Long, st As Long
st = Rng.Start
shdColor = ActiveDocument.Range(st, st).Font.Shading.BackgroundPatternColor
k = st + 1
Do
k = k + 1
If ActiveDocument.Range(k, k).Font.Shading.BackgroundPatternColor <> shdColor Then
If shdColor <> wdColorWhite Then
If ActiveDocument.Range(st - 1, st - 1).Font.Superscript Then st = st + 1
MsgBox count & ": Range " & st & "-" & k & vbCr & _
"Text: " & Chr(34) & ActiveDocument.Range(st - 1, k) & Chr(34) & vbCr & _
"RGB: " & GetRGB(shdColor)
count = count + 1
End If
st = k + 1
shdColor = ActiveDocument.Range(st, st).Font.Shading.BackgroundPatternColor
End If
Loop Until k >= Rng.End
' Case 9999999
' With Rng.Duplicate
' .Collapse wdCollapseStart
' Do While .End < Rng.End - 1
' If .Characters.Last.Next.Font.Shading.BackgroundPatternColor = _
' .Characters.First.Font.Shading.BackgroundPatternColor Then
' .End = .End + 1
' Else
' Select Case .Font.Shading.BackgroundPatternColor
' Case wdColorAutomatic
' Case wdColorWhite: .Collapse wdCollapseEnd
' Case Else
' MsgBox "Range: " & .Start & "-" & .End & vbCr & _
' "Text: " & Chr(34) & .Text & Chr(34) & vbCr & _
' "RGB: " & GetRGB(.Font.Shading.BackgroundPatternColor)
' .Collapse wdCollapseEnd
' End Select
' End If
' Loop
' End With
Case Else: MsgBox count & ": Range " & Rng.Start & "-" & Rng.End & vbCr & _
"Text: " & Chr(34) & Rng.Text & Chr(34) & vbCr & _
"RGB: " & GetRGB(.BackgroundPatternColor)
count = count + 1
End Select
End With
' If .Information(wdWithInTable) = True Then
' If .End = .Cells(1).Range.End - 1 Then
' .End = .Cells(1).Range.End
' .Collapse wdCollapseEnd
' If .Information(wdAtEndOfRowMarker) = True Then
' .End = .End + 1
' End If
' End If
' End If
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
j = .End
Loop
End With
Application.ScreenUpdating = True
End Sub
Function GetRGB(RGBvalue As Long) As String
Dim StrTmp As String
If RGBvalue < 0 Or RGBvalue > 16777215 Then RGBvalue = 0
StrTmp = StrTmp & " R: " & RGBvalue \ 256 ^ 0 Mod 256
StrTmp = StrTmp & " G: " & RGBvalue \ 256 ^ 1 Mod 256
StrTmp = StrTmp & " B: " & RGBvalue \ 256 ^ 2 Mod 256
GetRGB = StrTmp
End Function