Link to home
Create AccountLog in
Avatar of DrTribos
DrTribosFlag for Australia

asked on

Assign Color from String in MS Word

Hi All

I have list of colors:

and so on.

What I would like to do is apply shading to the paragraph text based on the text string, e.g. if text is wdColorBlue the paragraph should be shaded in that same color.

My code does not work, I'm stuck:
Sub applyColor()
Dim oPar As Paragraph, Color As WdColor, strColor As String

For Each oPar In Selection.Paragraphs
strColor = (Left(oPar.Range.Text, Len(oPar.Range.Text) - 1))
Color = strColor
oPar.Range.Shading.BackgroundPatternColor = Color
Next oPar
End Sub

Open in new window

I get a type mis-match at Color = strColor  :-(

Avatar of GrahamSkan
Flag of United Kingdom of Great Britain and Northern Ireland image

Morning/Evening Steve
There are several ways of defining colours in VB(A).

Internally a colour is a Long integer. This can be produced using the RGB function from the individual values or red, blue and green, so

Dim MyColour as long
MyColor = RGB(255,0,0)

defines Red (255)

Also there are several series of enumerated constants:

1. VBA.ColorConstants e.g. vbRed = 255
2. SystemColorConstants e.g.  vbButtonFace = -2147483633 (&H8000000F)
3. wdColor e.g. wdColorRed = 255
4. There is also a set of predefined colours with arbitrary index numbers:
wdColorIndex e.g. wdRed = 6

To convert a string to a colour would require using Select Case
Function GetColour(strColour As String) As Long
    Select Case strColour
        Case "PaleYellow"
            GetColour = &H99FFF
        Case "Red"
            GetColour = wdColorRed
    End Select
End Function

Open in new window

It is possible to copy the text from any of the enumeration list tables in the Help file on to a document and to use find and replace to construct the cases in the body of he Select Case block:
Something like this:
Sub FormatToSelectCase()
    With ActiveDocument.Tables(1)
        .ConvertToText vbTab
    End With
    With ActiveDocument.Range.Find
    .MatchWildcards = True
        .Text = "(wd[A-z0-9]{1,})^t([0-9\-]{1,})^t([A-z0-9 .\-]{1,})^13"
        .Replacement.Text = "Case \1^t'\2^p^tstrText = ""\3""^p"
        .Execute Replace:=wdReplaceAll
    End With
End Sub

Open in new window

Function GetColour(strColour As String) As Long
    Select Case strColour
        Case "wdColorYellow"
            GetColour = wdColorYellow
        Case "wdRed"
            GetColour = wdColorRed
    End Select
End Function
Avatar of DrTribos


Ok!  I do believe you have provided a solution to the problem I have.
Avatar of Rgonzo1971

Link to home
Create an account to see this answer
Signing up is free. No credit card required.
Create Account
Hats Off to you Rgonzo!!

Works a treat!