[Webinar] Streamline your web hosting managementRegister Today

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 884
  • Last Modified:

Assign Color from String in MS Word

Hi All

I have list of colors:
wdColorAqua
wdColorBlue
wd....

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  :-(

Thanks!
0
DrTribos
Asked:
DrTribos
  • 2
1 Solution
 
GrahamSkanRetiredCommented:
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
0
 
DrTribosAuthor Commented:
Ok!  I do believe you have provided a solution to the problem I have.
0
 
Rgonzo1971Commented:
Hi,

Herewith my solution with splitting the list as text

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))
If strColor <> "" Then
    Color = GetColorNumber(strColor)
oPar.Range.Shading.BackgroundPatternColor = Color
End If
Next oPar
End Sub

Function GetColorNumber(Colr As String) As Long

strColors = "wdColorAqua;13421619/wdColorAutomatic;-16777216/wdColorBlack;0/wdColorBlue;16711680/wdColorBlueGray;10053222/" & _
            "wdColorBrightGreen;65280/wdColorBrown;13209/wdColorDarkBlue;8388608/wdColorDarkGreen;13056/wdColorDarkRed;128/" & _
            "wdColorDarkTeal;6697728/wdColorDarkYellow;32896/wdColorGold;52479/wdColorGray05;15987699/wdColorGray10;15132390/" & _
            "wdColorGray125;14737632/wdColorGray15;14277081/wdColorGray20;13421772/wdColorGray25;12632256/wdColorGray30;11776947/" & _
            "wdColorGray35;10921638/wdColorGray375;10526880/wdColorGray40;10066329/wdColorGray45;9211020/wdColorGray50;8421504/" & _
            "wdColorGray55;7566195/wdColorGray60;6710886/wdColorGray625;6316128/wdColorGray65;5855577/wdColorGray70;5000268/" & _
            "wdColorGray75;4210752/wdColorGray80;3355443/wdColorGray85;2500134/wdColorGray875;2105376/wdColorGray90;1644825/" & _
            "wdColorGray95;789516/wdColorGreen;32768/wdColorIndigo;10040115/wdColorLavender;16751052/wdColorLightBlue;16737843/" & _
            "wdColorLightGreen;13434828/wdColorLightOrange;39423/wdColorLightTurquoise;16777164/wdColorLightYellow;10092543/" & _
            "wdColorLime;52377/wdColorOliveGreen;13107/wdColorOrange;26367/wdColorPaleBlue;16764057/wdColorPink;16711935/" & _
            "wdColorPlum;6697881/wdColorRed;255/wdColorRose;13408767/wdColorSeaGreen;6723891/wdColorSkyBlue;16763904/" & _
            "wdColorTan;10079487/wdColorTeal;8421376/wdColorTurquoise;16776960/wdColorViolet;8388736/wdColorWhite;16777215/wdColorYellow;65535"
            
            
arrColorLines = Split(strColors, "/")

For Each Colour In arrColorLines
    CoulourItem = Split(Colour, ";")
    If CoulourItem(0) = Colr Then
        GetColorNumber = CoulourItem(1)
        Exit Function
    End If
Next

End Function

Open in new window

Regards
0
 
DrTribosAuthor Commented:
Hats Off to you Rgonzo!!

Works a treat!
0

Featured Post

2018 Annual Membership Survey

Here at Experts Exchange, we strive to give members the best experience. Help us improve the site by taking this survey today! (Bonus: Be entered to win a great tech prize for participating!)

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now