vba control of shading

Tony · #16 04-08-2021, 05:41 PM

Thank you, macropod, for your code. I tried it on the test.docx I provided and it seems to work for the first line.

But then it seems to get stuck in this loop when it hits a particular wdColorAutomatic

Code:

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
...
                End Select

...

Tony · #17 04-08-2021, 05:44 PM

I only mentioned the "comments/notes" part because I was asked early on by gmayor what my aim was. But that has nothing to do with the current problem.

I need to solve the current problem with not being able to locate each colored shading range. Only then I will introduce comments/notes. But the current documents have no comments/notes.

macropod · #18 04-08-2021, 05:52 PM

Quote:

Originally Posted by Tony

Thank you, macropod, for your code. I tried it on the test.docx I provided and it seems to work for the first line.

But then it seems to get stuck in this loop when it hits a particular wdColorAutomatic

The code works fine for me with your test document.

Tony · #19 04-08-2021, 06:03 PM

macropod: The code works fine for me with your test document.

I just tried it again and it works fine for the first 4 highlights (in the first line) but then it get's stuck and never finds the highlight info for the turquoise " uif 5ifbwfot boe u"

Do you get info for that one?

macropod · #20 04-08-2021, 06:43 PM

I developed and tested the code on your original attachment. It works equally well on your updated attachments, returning 19 range reports.

Tony · #21 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

macropod · #22 05-06-2021, 08:59 PM

Try the following. Just don't expect stellar performance.

Code:

Sub ShadingTest()
Dim Rng As Range, Clr As Long, i As Long, StrOut As String, Tbl As Table
With ActiveDocument
  Set Rng = .Range(0, 0)
  With Rng
    Do While .End < ActiveDocument.Range.End
      Clr = .Characters.First.Shading.BackgroundPatternColor
      Do While .Characters.Last.Next.Shading.BackgroundPatternColor = Clr
        If .End = ActiveDocument.Range.End - 1 Then Exit Do
        .End = .End + 1
      Loop
      Select Case Clr
      Case wdColorAutomatic, wdColorWhite
      Case Else
        i = i + 1
        StrOut = StrOut & vbCr & i & vbTab & .Start & "-" & .End & vbTab & _
          GetRGB(.Font.Shading.BackgroundPatternColor) & vbTab & .Text
      End Select
      .Collapse wdCollapseEnd
      .End = .End + 1
    Loop
    .InsertAfter "Item" & vbTab & "Range" & vbTab & "R" & vbTab & "G" & vbTab & "B" & vbTab & "Content:" & StrOut
    .ConvertToTable
    .End = .End + 1
    With .Tables(1)
      .Columns.AutoFit
      .Sort Excludeheader:=True, _
        FieldNumber:=3, SortFieldType:=wdSortFieldNumeric, SortOrder:=wdSortOrderAscending, _
        FieldNumber2:=4, SortFieldType2:=wdSortFieldNumeric, SortOrder2:=wdSortOrderAscending, _
        FieldNumber3:=5, SortFieldType3:=wdSortFieldNumeric, SortOrder3:=wdSortOrderAscending
    End With
  End With
End With
End Sub

Function GetRGB(RGBvalue As Long) As String
Dim StrTmp As String
If RGBvalue < 0 Or RGBvalue > 16777215 Then RGBvalue = 0
StrTmp = RGBvalue \ 256 ^ 0 Mod 256
StrTmp = StrTmp & vbTab & RGBvalue \ 256 ^ 1 Mod 256
StrTmp = StrTmp & vbTab & RGBvalue \ 256 ^ 2 Mod 256
GetRGB = StrTmp
End Function

Tony · #23 05-06-2021, 10:51 PM

nanopod,

I did try the latest code you posted, and you're right -- it's a lot slower. Over 6 times slower on the test.docx, as you can see below in the comparison I made.

In this comparison, results from the Demo_modified() code I posted are on the left and result from your latest code is on the right. The text in red font shows where your latest code produced different results. Your latest code accurately reports the shading in test.docx for the 3 cases which differ. The differences here are minor, however: just a space or non-printing character. The range start differences are also minor, and it's not clear to me which one is correct.

For completeness, I'm also including the Excel version of the Demo_modified() code that I find most helpful. Although I first verified that the code we've been discussing works in Word, I prefer to work in Excel for a number of reasons.

Code:

Sub Demo_modified_Excel()
' note: this is Excel VBA that manipulates a Word document
' so you must add a reference to the Word-library (Microsoft Word 16.0 Object Library)
' also assumes Word doc is located at Z:\test.docx
Dim wApp As Word.Application, wDoc As Word.Document, wRng As Word.Range
Dim sh As Worksheet, r As Range, kD As Date
Dim i As Long, j As Long
Dim shdColor As Long, k As Long, st As Long
Const filePath = "Z:\test.docx"
kD = Now
Set sh = ThisWorkbook.ActiveSheet
Set r = sh.Range("A1") 'prepare for output to Excel
sh.Cells.Clear
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
Set wDoc = wApp.Documents.Open(filePath)
With wDoc.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 wRng = wDoc.Range(j, .Start)
    With wRng.Font.Shading
      Select Case .BackgroundPatternColor
        Case wdColorAutomatic
        Case wdColorWhite
        Case wdUndefined '9999999  ie, mix of shade colors
          st = wRng.Start
          shdColor = wDoc.Range(st, st).Font.Shading.BackgroundPatternColor
          k = st + 1
          Do
            k = k + 1
            If wDoc.Range(k, k).Font.Shading.BackgroundPatternColor <> shdColor Then
              If shdColor <> wdColorWhite Then
                If wDoc.Range(st - 1, st - 1).Font.Superscript Then st = st + 1
                shadeOutput r, st, k, wDoc.Range(st - 1, k), shdColor
              End If
              st = k + 1
              shdColor = wDoc.Range(st, st).Font.Shading.BackgroundPatternColor
            End If
          Loop Until k >= wRng.End
        'deal with real colors; ie, not white, auto or mixed
        Case Else: shadeOutput r, wRng.Start, wRng.End, wRng.Text, .BackgroundPatternColor
      End Select
    End With 
    If .End = wDoc.Range.End Then Exit Do
    .Collapse wdCollapseEnd
    j = .End
  Loop
End With
Columns("A:D").EntireColumn.AutoFit
wApp.Quit True
Set wDoc = Nothing
Set wApp = Nothing
r = r.Row - 1 & " shaded regions found. Elapsed time: " & Format((Now - kD), "HH:MM:SS")
sh.Activate
r.Select
End Sub

Sub shadeOutput(r As Range, st As Long, ed As Long, txt As String, shd As Long)
With r 'ouput info about each shaded region on active sheet
  .Offset(0, 0) = st  'start point for shaded text
  .Offset(0, 1) = ed 'ending point for shaded text
  .Offset(0, 2) = txt
  .Offset(0, 2).Interior.Color = shd
  .Offset(0, 3) = shd
End With
Set r = r.Offset(1, 0)
End Sub

Tony · #24 05-19-2021, 08:31 AM

After learning more, I've improved the code I posted above. This version improves accuracy and is faster.

Again, this is Excel VBA which manipulates Word documents so for it to work you need to do this in the IDE: Tools>References...>Microsoft Word 16.0 Object Library

Code:

Sub callShadingFinder()
'This code loops through all word files in the same directory as the Excel document
Dim s As String
Const ext = "docx"
s = dir(ThisWorkbook.path & "\*" & ext)
While s <> ""
  ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = Left(s, InStr(s, ext) - 2)
  shadingFinder ThisWorkbook.path & "\" & s
  s = dir()
Wend
End Sub

Sub shadingFinder(filePath As String)
'problems: includes para mark when shading at end of line
Dim wApp As Word.Application, wDoc As Word.Document, wRng As Word.Range
Dim sh As Worksheet, r As Range, kD As Date
Dim shdColor As Long, shdStart As Long, shdEnd As Long
kD = Now
Set sh = ThisWorkbook.ActiveSheet
'Set testR = sh.Range("F1")
Set r = sh.Range("A1") 'prepare Excel to list output
sh.Cells.Clear
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open(filePath)
wApp.Visible = False
Application.ScreenUpdating = False
With wDoc.Range
  With .Find 'determine where shaded text is based on where unshaded text is
    .ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Execute Replace:=wdReplaceAll
    .Wrap = wdFindStop
    .Font.Shading.BackgroundPatternColor = wdColorAutomatic 'unshaded text
  End With
  '.range(0,1] =first char of doc, .range(1,2] =second char, ...
  Do While .Find.Execute
    shdEnd = .Start: Set wRng = wDoc.Range(shdStart, shdEnd)
    With wRng.Font.Shading
      Select Case .BackgroundPatternColor
        Case wdColorAutomatic
        Case wdColorWhite
        Case wdUndefined '9999999  ie, mix of shade colors
          'step thru each char comparing its shading with first shaded char
          shdColor = wDoc.Range(shdStart, shdStart + 1).Font.Shading.BackgroundPatternColor
          shdEnd = shdStart
          Do
            shdEnd = shdEnd + 1
            If wDoc.Range(shdEnd, shdEnd + 1).Font.Shading.BackgroundPatternColor <> shdColor Then
              If shdColor <> wdColorWhite Then
                  shadeOutput r, shdStart, shdEnd, wDoc.Range(shdStart, shdEnd), shdColor
              End If
              'redefine first shaded character
              shdStart = shdEnd
              shdColor = wDoc.Range(shdStart, shdStart + 1).Font.Shading.BackgroundPatternColor
            End If
          Loop Until shdEnd >= wRng.End
        'deal with real colors; ie, not white, auto or mixed
        Case Else: shadeOutput r, wRng.Start, wRng.End, wRng.Text, .BackgroundPatternColor
      End Select
    End With
    If .End = wDoc.Range.End Then Exit Do
    .Collapse wdCollapseEnd
    shdStart = .End
    Application.StatusBar = "for " & filePath & ": " & r.Row - 1 & " shaded regions found: " & Format(shdStart / wDoc.Characters.Count, "0%")
  Loop
End With
Columns("A:D").EntireColumn.AutoFit
wApp.Quit True
Set wDoc = Nothing
Set wApp = Nothing
r = r.Row - 1 & " shaded regions found. Elapsed time: " & Format((Now - kD), "HH:MM:SS")
sh.Activate
r.Select
Application.ScreenUpdating = True
End Sub

Sub shadeOutput(r As Range, st As Long, ed As Long, txt As String, shd As Long)
With r 'ouput info about each shaded region on active sheet
  .Offset(0, 0) = st  'start point for shaded text
  .Offset(0, 1) = ed 'ending point for shaded text
  .Offset(0, 2) = txt
  .Offset(0, 2).Interior.Color = shd
  .Offset(0, 3) = shd
End With
Set r = r.Offset(1, 0)
End Sub

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Show field shading in Content Control	ajanson	Word	3	08-15-2016 04:49 PM
Clicking the selected Content Control checkbox returns wrong control in vba event	DougsGraphics	Word VBA	2	06-24-2015 07:31 AM
Question: How to maintain gray shading in text control box	tluken	Word	1	08-23-2012 10:20 AM
Shading, but only when printed	WilltheGrill09	Word	1	03-27-2012 02:44 AM
Equations shading	b0x4it	Word	4	05-18-2011 07:54 PM