Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #16  
Old 04-08-2021, 05:41 PM
Tony Tony is offline vba control of shading Windows 10 vba control of shading Office 2019
Novice
vba control of shading
 
Join Date: Apr 2021
Posts: 12
Tony is on a distinguished road
Default

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
...
Reply With Quote
  #17  
Old 04-08-2021, 05:44 PM
Tony Tony is offline vba control of shading Windows 10 vba control of shading Office 2019
Novice
vba control of shading
 
Join Date: Apr 2021
Posts: 12
Tony is on a distinguished road
Default

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.
Reply With Quote
  #18  
Old 04-08-2021, 05:52 PM
macropod's Avatar
macropod macropod is offline vba control of shading Windows 10 vba control of shading Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,176
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
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.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #19  
Old 04-08-2021, 06:03 PM
Tony Tony is offline vba control of shading Windows 10 vba control of shading Office 2019
Novice
vba control of shading
 
Join Date: Apr 2021
Posts: 12
Tony is on a distinguished road
Default

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?
Reply With Quote
  #20  
Old 04-08-2021, 06:43 PM
macropod's Avatar
macropod macropod is offline vba control of shading Windows 10 vba control of shading Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,176
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

I developed and tested the code on your original attachment. It works equally well on your updated attachments, returning 19 range reports.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #21  
Old 05-06-2021, 05:18 AM
Tony Tony is offline vba control of shading Windows 10 vba control of shading Office 2019
Novice
vba control of shading
 
Join Date: Apr 2021
Posts: 12
Tony is on a distinguished road
Default

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
Reply With Quote
  #22  
Old 05-06-2021, 08:59 PM
macropod's Avatar
macropod macropod is offline vba control of shading Windows 10 vba control of shading Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,176
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

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
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #23  
Old 05-06-2021, 10:51 PM
Tony Tony is offline vba control of shading Windows 10 vba control of shading Office 2019
Novice
vba control of shading
 
Join Date: Apr 2021
Posts: 12
Tony is on a distinguished road
Default Excel version

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
Attached Images
File Type: jpg comparison.jpg (100.8 KB, 9 views)
Reply With Quote
  #24  
Old 05-19-2021, 08:31 AM
Tony Tony is offline vba control of shading Windows 10 vba control of shading Office 2019
Novice
vba control of shading
 
Join Date: Apr 2021
Posts: 12
Tony is on a distinguished road
Default Improved code

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
Reply With Quote
Reply

Thread Tools
Display Modes


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

Other Forums: Access Forums - Senior Forums

All times are GMT -7. The time now is 12:11 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2021, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2021 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft