#16
|
|||
|
|||
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 |
#17
|
|||
|
|||
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. |
#18
|
||||
|
||||
The code works fine for me with your test document.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#19
|
|||
|
|||
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? |
#20
|
||||
|
||||
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] |
#21
|
|||
|
|||
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 |
#22
|
||||
|
||||
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] |
#23
|
|||
|
|||
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 |
#24
|
|||
|
|||
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 |
Thread Tools | |
Display Modes | |
|
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 |