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

[Sam1085]

Thank you Paul!

[Sam1085]

Hi

I tried to get the color information to excel sheet instead of massage box. I tried as follows to do this.

Code:

Code: Select all

Sub FindRGB()
    Dim i             As Long
    Dim xl            As Object
    Dim wb            As Object
    Dim sh            As Object
    Dim rg            As Object
    Dim sName         As String
    Dim StrClrArr     As String
    Dim StrClr        As String
    Dim lngColor      As Long
    
If ActiveDocument.Words.Count = 1 Then
     MsgBox "Seems like this is empty document! Please check and try again.", vbExclamation
  Exit Sub
Else

Application.ScreenUpdating = False
Options.Pagination = False

    ' ~~> Create Tempory File to Process the Macro
    Application.Documents.Add ActiveDocument.FullName
    Set doc = ActiveDocument
    
    On Error Resume Next
    Set xl = GetObject(, "Excel.Application")
    If xl Is Nothing Then
        Set xl = CreateObject("Excel.Application")
        xl.Visible = True
    End If
    sName = "C:\Users\Downloads\Style Checklist.xltm" ' Template path need to be update
    Set wb = xl.Workbooks.Open(sName)
    If wb Is Nothing Then Set wb = xl.Workbooks.Add
    On Error GoTo 0
    Set sh = wb.Sheets(2)
    sh.Columns(1).ColumnWidth = 50
    
    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
    
    Set rg = sh.Range("B40")
    With xl
        rg.Offset(0, 0) = StrClrArr
    End With
    
    ' ~~> Close Document Without Save
    doc.Close False
End If

    ' ~~> Release object memory
    Set wb = Nothing
    Set xl = Nothing
    Set sh = Nothing

    Application.ScreenUpdating = True
    Options.Pagination = True
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

It works now but I don't know how to break-down each color values separately.

Current result:

current.png

Expected result:

expected.png

Thank you!

[Rudi]

Change this line:

StrClrArr = StrClrArr & vbCr & StrClr

To this:

StrClrArr = StrClrArr & vbLf & StrClr

(or vbCrLf or vbNewLine)

[macropod]

Try:

Code: Select all

Sub FindRGBColours()
Application.ScreenUpdating = False
Dim StrClrArr As String, StrClr As String
StrClrArr = vbCr & vbTab & "R" & vbTab & "G" & vbTab & "B"
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
Call SendToExcel(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 & vbTab & 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

Sub SendToExcel(StrTxt As String)
Dim xlApp As Object, xlWkBk As Object, r As Long, c As Long
On Error Resume Next
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  .Visible = True
  .ScreenUpdating = False
  Set xlWkBk = .Workbooks.Add
  With xlWkBk.Sheets(1)
    For r = 1 To UBound(Split(StrTxt, vbCr))
      For c = 1 To UBound(Split(Split(StrTxt, vbCr)(r), vbTab))
        .Cells(r, c).Value = Split(Split(StrTxt, vbCr)(r), vbTab)(c)
      Next
    Next
  End With
  .ScreenUpdating = True
End With
End Sub

[Rudi]

Ooops!!
I completely overlooked the obvious requirement to divide it into rows.
It comes from trying to be smart and answering posts before my morning coffee.

[Sam1085]

Thank you Rudi and Paul,

I found a "SUBSTITUTE" formula to wrap those RGB values in a single cell. I think preferred with that formula for my work.

Anyway thank you guys!