How to determine all RGB color values in Word by a Macro

[Sam1085]

Hi,

I've a excel macro to identify cell fill color Hex value.

Code: Select all

MsgBox Hex(ActiveCell.Interior.Color)

I need the same thing in Word. Is it possible to create a macro to determine the entire document font RGB color values (Not Hex)?

Thank you!

[HansV]

Since one can color a Word document at the character level, you would have to loop through the characters in the document and look at their color, but it would be very slow.

Moreover, for many characters, VBA will return the numeric value of the theme color, not the RGB color

[Sam1085]

I understood Hans. Thank you!

[Sam1085]

I think all font related styles saved inside the word file as xml data. (Such as style sheet in a web page) But, unfortunately it's much hard to determine a color value.

[HansV]

What do you need this for?

[Sam1085]

Basically I planned to extract all RGB color values from a Word document. Currently I've to select the headings, paragraphs one by one and make a note for RGB color. It'll take few minutes. That's the actual reason for this. As you said earlier it'll take too much time to complete the process.

[HansV]

But WHY do you want to extract all RGB values from a document? What do you want to use this information for?

[Sam1085]

In my documents, I need to match all colors consistently. And I've to fix all inconsistencies in through the document. If I extracted the color codes with count then It'll help me to fix inconsistencies. And some times, I've to match pdf RGB color codes with Word file. Earlier you provided few codes to find and replace table shading, font color... etc. Those macros are really helpful for my work.

[HansV]

If you need to remove inconsistencies, it's best to remove all directly applied formatting by selecting the entire document and pressing Ctrl+spacebar and Ctrl+Q, or in VBA:

ActiveDocument.Content.Font.Reset
ActiveDocument.Content.ParagraphFormat.Reset

and then use styles to apply formatting consistently.

[Sam1085]

Thank you Hans for the suggestion. I think the above mentioned method same as Ctrl+Shift+N.

[HansV]

No, if you select the entire document, Ctrl+Shift+N applies the Normal style to the document, but leaves directly applied font formatting alone. Ctrl+spacebar removes all directly applied font formatting.

[Sam1085]

Now I got your point exactly. But my documents formatted by 100% direct formatting. It's never use styles. That's the main problem in my docs. Anyway thank you for sharing with your experience.

[HansV]

I recommend using styles instead of direct formatting. See Tips for Understanding Styles in Word, in particular the section 'What is the advantage of modifying a style as opposed to formatting my text directly?'

[macropod]

To retrieve the RGB values of the colours used in the text, try:

Code: Select all

Sub FindRGBColours()
Application.ScreenUpdating = False
Dim StrClrArr As String, StrClr As String
With ActiveDocument.Range
  .Font.Hidden = True
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .MatchWildcards = True
    .Text = "?"
    .Forward = True
    .Format = True
    .Font.Hidden = True
    .Wrap = wdFindStop
    .Execute
  End With
  Do While .Find.Found
    StrClr = .Font.Color
    StrClrArr = StrClrArr & vbCr & GetRGB(CLng(StrClr))
    With .Duplicate.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Font.Color = StrClr
      .Replacement.Font.Hidden = False
      .Wrap = wdFindStop
      .Execute Replace:=wdReplaceAll
    End With
    .Font.Hidden = True
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
MsgBox StrClrArr
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

[HansV]

Hi Paul,

When I try your code on a document that contains several colors, the effect is that (1) all text in the document is hidden, and (2) an empty message box is displayed.

[macropod]

When I run the macro, I get a Message Box output like:

R: 0 G: 0 B: 0
R: 192 G: 0 B: 0
R: 255 G: 0 B: 0
R: 255 G: 192 B: 0
R: 255 G: 255 B: 0
R: 146 G: 208 B: 80
R: 0 G: 176 B: 80
R: 0 G: 176 B: 240
R: 0 G: 112 B: 192
R: 0 G: 32 B: 96
R: 112 G: 48 B: 160

Note: the second '.Font.Hidden = True' should be deleted, as it leaves the first character in each colour hidden, but it doesn't affect the report.

[HansV]

Paul, if I reverse Font.Hidden = False and Font.Hidden = True in your code (and then unhide all text at the end), I get this:

S331.jpg

This is because I applied theme colors; here are the 'raw' color values:

S332.jpg

[HansV]

The following version handles both RGB colors and theme colors. I tested it in Word 2010.

Code: Select all

Sub FindRGBColours()
    Application.ScreenUpdating = False
    Dim StrClrArr As String, StrClr As String, lngColor As Long
    With ActiveDocument.Range
        .Font.Hidden = False
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .MatchWildcards = True
            .Text = "?"
            .Forward = True
            .Format = True
            .Font.Hidden = False
            .Wrap = wdFindStop
            .Execute
        End With
        Do While .Find.Found
            lngColor = .Font.TextColor
            Select Case .Font.TextColor.Type
                Case msoColorTypeRGB
                    StrClr = GetRGB(.Font.TextColor.RGB)
                Case msoColorTypeScheme
                    StrClr = GetThemeColor(.Font.TextColor.ObjectThemeColor)
                Case Else
                    StrClr = "Other"
            End Select
            StrClrArr = StrClrArr & vbCr & StrClr
            With .Duplicate.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Font.Color = lngColor
                .Replacement.Font.Hidden = True
                .Wrap = wdFindStop
                .Execute Replace:=wdReplaceAll
            End With
            .Collapse wdCollapseEnd
            .Find.Execute
        Loop
    End With
    ActiveDocument.Range.Font.Hidden = False
    Application.ScreenUpdating = True
    MsgBox StrClrArr
End Sub

Function GetRGB(RGBvalue As Long) As String
    Dim StrTmp As String
    If RGBvalue < 0 Or RGBvalue > 16777215 Then RGBvalue = 0
    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

Function GetThemeColor(ThemeColor As Long) As String
    Select Case ThemeColor
        Case wdThemeColorAccent1
            GetThemeColor = "Accent color 1"
        Case wdThemeColorAccent2
            GetThemeColor = "Accent color 2"
        Case wdThemeColorAccent3
            GetThemeColor = "Accent color 3"
        Case wdThemeColorAccent4
            GetThemeColor = "Accent color 4"
        Case wdThemeColorAccent5
            GetThemeColor = "Accent color 5"
        Case wdThemeColorAccent6
            GetThemeColor = "Accent color 6"
        Case wdThemeColorBackground1
            GetThemeColor = "Background color 1"
        Case wdThemeColorBackground2
            GetThemeColor = "Background color 2"
        Case wdThemeColorHyperlink
            GetThemeColor = "Hyperlink color"
        Case wdThemeColorHyperlinkFollowed
            GetThemeColor = "Followed hyperlink color"
        Case wdThemeColorMainDark1
            GetThemeColor = "Dark main color 1"
        Case wdThemeColorMainDark2
            GetThemeColor = "Dark main color 2"
        Case wdThemeColorMainLight1
            GetThemeColor = "Light main color 1"
        Case wdThemeColorMainLight2
            GetThemeColor = "Light main color 2"
        Case wdThemeColorText1
            GetThemeColor = "Text color 1"
        Case wdThemeColorText2
            GetThemeColor = "Text color 2"
    End Select
End Function

Unfortunately, it doesn\t distinguish between the lighter and darker shades of a theme color, nor do I know how to convert theme colors and their shades to RGB colors.

[Sam1085]

Thank you Paul and Hans!

You guys are awesome!!!

Earlier I think about this way. Track changes on >> Find black color and automatic color (more than 95% use this two colors in my documents) >> If found black or, and automatic color then delete all characters >> Find the rest of the characters for RGB color >> Reject all to restore the document.

But I think your method is the best one.

May I know how to get color codes from selected text range? I changed line 4 as follows. But I got a run time error.

Code: Select all

With ActiveDocument.Selection.Range

Thank you!

[macropod]

To work with a selected range, multiple code changes are needed, to incorporate an .InRange test. Assuming you're working with the code I posted, try:

Code: Select all

Sub FindRGBColours()
Application.ScreenUpdating = False
Dim Rng As Range, StrClrArr As String, StrClr As String
Set Rng = Selection.Range
With Selection.Range
  .Font.Hidden = True
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .MatchWildcards = True
    .Text = "?"
    .Forward = True
    .Format = True
    .Font.Hidden = True
    .Wrap = wdFindStop
    .Execute
  End With
  Do While .Find.Found
    If Not .InRange(Rng) Then Exit Do
    StrClr = .Font.Color
    StrClrArr = StrClrArr & vbCr & GetRGB(CLng(StrClr))
    With .Duplicate
      .End = Rng.End
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Font.Color = StrClr
        .Replacement.Font.Hidden = False
        .Wrap = wdFindStop
        .Execute Replace:=wdReplaceAll
      End With
    End With
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
MsgBox StrClrArr
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