CODEWITHSUNDEEP
vbadrop-down-menucolorsms-word
Dave
Dave

Reputation: 1175

MS Word, Colour change linked to dropdown menu

I have a Word template with options within the header, one of which is the type of document it relates to. I have cytotoxic and monoclonal options to be selected from a drop down menu.

I need to have some identifier colours displayed on the document, Yellow for cytotoxic and Blue for monoclonal. To help with quick recognition for better usability.

Is there a way to alter a shape or text box colour depending on which option is selected?

edit The template is a work in progress so not 100% sure where the colour will be added, would just like it automated for uniformity as it will be applied to many documents. And worked on by different people.

I'm after an excel conditional formatting type effect where if the drop down shows cytotoxic colour gets applied. It could be a shape, textbox, cell or font, I could work with whichever is possible to be linked.

Thanks for any help!

Upvotes: 0

Views: 2447

Answers (1)

Variatus
Variatus

Reputation: 14373

Please paste the code below in the ThisDocument code sheet of your template and save it as macro enabled, in DOTM or DOCM format.

Add an ActiveX combobox to your template. By default it has the name "ComboBox1". You will find that the code refers to it by this name.

Add a rectangular shape to your template. I made this more like a bar, about 5mm high and across the entire page width. By default, Word will call it "Rectangle 1". Note that the code refers to it by this name.

Option Explicit

Private Sub Document_Open()
    ' 16 Nov 2017

    Dim iShp As InlineShape
    Dim Shp As Shape
    Dim ShapesCount As Integer

    For Each iShp In ActiveDocument.InlineShapes
        With iShp
            If .Type = wdInlineShapeOLEControlObject Then
                If StrComp(.OLEFormat.Object.Name, "ComboBox1", vbTextCompare) _
                           = 0 Then ShapesCount = ShapesCount + 1
            End If
        End With
    Next iShp

    For Each Shp In ActiveDocument.Shapes
        With Shp
            If .Type = msoAutoShape Then
                If StrComp(.Name, "Rectangle 1", vbTextCompare) _
                           = 0 Then ShapesCount = ShapesCount + 1
            End If
        End With
    Next Shp

   If ShapesCount < 2 Then
        MsgBox "One of the required shapes is missing.", _
               vbInformation, "Corrupted document"
        Exit Sub
    Else
        With ActiveDocument
            With .ComboBox1
                .List = Array("Cycotoxic", "Monoclonic")
                If .ListIndex < 0 Then .ListIndex = 0
            End With
        End With
    End If
End Sub

Private Sub ComboBox1_Change()
    ' 16 Nov 2017
    Shapes("Rectangle 1").Fill.ForeColor = Array(vbYellow, 15773696)(ComboBox1.ListIndex)
End Sub

When you open the document the Document_Open event procedure will run (for testing, you can also run it manually). It checks if the two shapes are present - one an Inlineshape, the other a normal shape - and gives an error message if one of them is missing. It will also add the two choices to the Combobox. You will find the names in the code (in case I misspelled them).

Now, when you change the selection the colour of the bar will toggle between yellow and blue.

Statistics: 32 lines of supporting code so that one lone line can do all the work.

The following code will have the rectangle in the header. Unfortunately, it isn't possible to have an ActiveX control in the header, but you might format the ComboBox to have no frame and let the dropdown arrow only appear when you hover the mouse over it so that the selected word appears as part of the document's text, perhaps even its title.

Option Explicit

Private Sub Document_Open()
    ' 17 Nov 2017

    Dim iShp As InlineShape

    For Each iShp In ActiveDocument.InlineShapes
        With iShp
            If .Type = wdInlineShapeOLEControlObject Then
                If StrComp(.OLEFormat.Object.Name, "ComboBox1", vbTextCompare) = 0 Then
                    With .OLEFormat.Object
                        .List = Array("Cycotoxic", "Monoclonic")
                        If .ListIndex < 0 Then .ListIndex = 0
                    End With
                End If
            End If
        End With
    Next iShp
End Sub

Private Sub ComboBox1_Change()
    ' 17 Nov 2017

    Dim Sect As Object, Story As Object
    Dim Shp As Shape

    With ActiveDocument
        For Each Sect In .Sections
            For Each Story In Sect.Headers
                For Each Shp In Story.Shapes
                    With Shp
                        If .Type = msoAutoShape Then
                            If StrComp(.Name, "Rectangle 1", vbTextCompare) = 0 Then
                                Shap.Fill.ForeColor = Array(vbYellow, 15773696)(ComboBox1.ListIndex)
                            End If
                        End If
                    End With
                Next Shp
            Next Story
        Next Sect
    End With
End Sub

Note that this version doesn't inspect the document for the presence of either ComboBox or Rectangle. Instead, if the ComboBox is found its dropdown list is set. If it isn't found nothing will happen. And if there is no ComboBox to call its change event the colour in the rectangle won't change, especially if it doesn't exist.

Upvotes: 1

Related Questions