playing around with excel dressup - http://ramblings.mcpher.com

colorizing.vba

Option Explicit
Const startOfTable = "dressup!h1"
Const shapeNameColumn = "spot"
Const shapeColorColumn = "color"
Const originalColorColumn = "originalColor"
Const startOfSwatch = "dressup!l1"

Public Sub applyNewColors()
    applyColors shapeColorColumn
End Sub
Public Sub restoreOriginalColors()
    applyColors originalColorColumn
End Sub
Public Sub makeANewSwatchAndApply()
    buildSwatch
    applyNewColors
End Sub
Private Sub applyColors(colorColumn As String)
    Dim ds As cDataSet
    Dim shp As shape, rInput As Range, dr As cDataRow
    Set rInput = Range(startOfTable)

    'get look up table
    Set ds = New cDataSet
    
    With ds.populateData(toEmptyBox(rInput), , , , , , , shapeNameColumn)
        For Each dr In .rows
            ' find the shape to be colored
            With dr.cell(shapeNameColumn)
                Set shp = findShape(.toString, rInput.Worksheet)
                If shp Is Nothing Then
                    MsgBox ("cannot find shape " & .toString & " in worksheet " & rInput.Worksheet.name)
                Else
                    shp.Fill.ForeColor.rgb = htmlHexToRgb(dr.value(colorColumn))
                End If
            End With
        Next dr
        'cleanup
        .tearDown
    End With
End Sub

Public Sub storeOriginalColors()
    Dim ds As cDataSet, shp As shape, rInput As Range, dr As cDataRow

    Set rInput = Range(startOfTable)
    'get look up table
    Set ds = New cDataSet
    
    With ds.populateData(toEmptyBox(rInput), , , , , , , shapeNameColumn)
        For Each dr In .rows
            ' find the shape to be colored
            With dr.cell(shapeNameColumn)
                Set shp = findShape(.toString, rInput.Worksheet)
                If shp Is Nothing Then
                    MsgBox ("cannot find shape " & .toString & " in worksheet " & rInput.Worksheet.name)
                Else
                    dr.cell(originalColorColumn).value = rgbToHTMLHex(shp.Fill.ForeColor.rgb)
                End If
            End With
        Next dr
        .column(originalColorColumn).Commit
        'cleanup
        .tearDown
    End With
End Sub
Public Sub buildSwatch()
    Dim ds As cDataSet, r As Range, n As Variant, i As Long, _
        c As Variant, dsColorTable As cDataSet, _
        p As colorProps, dsColor As cDataSet, dc As cCell, rInput As Range
    
    Set rInput = Range(startOfSwatch)
    ' this is whether the titlefor the swatch is

    Set ds = New cDataSet
    With ds.populateData(toEmptyBox(rInput))
        ' get the color table
        Set dsColorTable = getcolorMap()
        ' get colors and names of the years
        With .headings(2)
            c = getPantoneColorsOfTheYear(.value, , dsColorTable)
            n = getPantoneColorsOfTheYear(.value, "name", dsColorTable)
        End With
        ' clear the current one
        If Not .where Is Nothing Then
            .where.clear
        End If
        ' make the new ones
        For i = LBound(c) To UBound(c)
            p = makeColorProps(CLng(c(i)))
            With .headingRow.where.Offset(1 + i - LBound(c)).Resize(, 2)
                .Resize(, 1).value = n(i)
                .Interior.Color = p.rgb
                .Font.Color = p.textColor
            End With
        Next i

        ' we need to force a recalc of the colors column so ther change event will be called.. bit of a hack
        Set dsColor = New cDataSet
        With dsColor.populateData(toEmptyBox(Range(startOfTable)))
            For Each dc In .column(shapeColorColumn).rows
                dc.where.Formula = dc.where.Formula
            Next dc
            .tearDown
        End With
        dsColorTable.tearDown
        .tearDown
    End With
    
End Sub