Quote:
Originally Posted by Tony
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