Thread: [Solved] vba control of shading
View Single Post
 
Old 04-08-2021, 03:58 PM
macropod's Avatar
macropod macropod is offline Windows 10 Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,200
macropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant future
Default

Quote:
Originally Posted by Tony View Post
My aim is to associate comments/notes which are unique to each shaded region.
If you're using Word's Comment tool, one can easily retrieve the range with which each comment is associated, in which case your shading is irrelevant. See, for example:
Export Comments with referred text and line numbers from Word to Excel | MrExcel Message Board

Still, if you want to get the shading ranges and their RGB colours:
Code:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, Rng As Range
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
        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 "Range: " & Rng.Start & "-" & Rng.End & vbCr & _
          "Text: " & Chr(34) & Rng.Text & Chr(34) & vbCr & _
          "RGB: " & GetRGB(.BackgroundPatternColor)
      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
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote