Thread: [Solved] vba control of shading
View Single Post
Old 05-06-2021, 10:51 PM
Tony Tony is offline Windows 10 Office 2019
Join Date: Apr 2021
Posts: 12
Tony is on a distinguished road
Default Excel version


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.

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
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
Set wDoc = wApp.Documents.Open(filePath)
With wDoc.Range
  With .Find
    .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
            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
End With
wApp.Quit True
Set wDoc = Nothing
Set wApp = Nothing
r = r.Row - 1 & " shaded regions found. Elapsed time: " & Format((Now - kD), "HH:MM:SS")
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
Attached Images
File Type: jpg comparison.jpg (100.8 KB, 9 views)
Reply With Quote