Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
playing around with excel dressup - http://ramblings.mcpher.com
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.