Microsoft Office Forums - View Single Post

Tony · 05-06-2021, 05:18 AM

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