J
jamesdbrown1979
I have a generic VBA routine that adds a specified shape to each cell within
a target range on a worksheet and defines the
Shape.Fill.ForeColor.SchemeColor property and the OnAction event. The
OnAction event routine then toggles the Shape.Fill.Visible property on and
off which should change the colour to the already defined
Shape.Fill.ForeColor.SchemeColor property and back again, but the colour
always defaults to turquoise rather than the colour I've specified. The code
detailed below worked fine in Excel 2003, this appears to be a bug in 2007.
--------------------------------------------
Worksheet code (sheet1 in this instance). Run sub TestAddMarkers to add the
worksheet shapes which you can then click to run the OnAction code.
Option Explicit
Public Sub TestAddMarkers()
Marker_AddMarkers Sheet1.Range("A1:A5"), "Sheet1.ToggleMarker"
End Sub
Public Sub ToggleMarker()
Marker_HandleMarkerClick Sheet1.Shapes(Application.Caller)
Marker_SetMarkersInRange Sheet1.Range("A1:A5")
End Sub
-----------------------------------------------
Module level code detailed below...
Option Explicit
Public Enum tColorIndex
' Colors are in same order as on color pallete, down and across
mxlAutomaticColor = 0
mxlNoColor = -4142
mxlBlack = 1
mxlDarkRed = 9
mxlRed = 3
mxlPink = 7
mxlRose = 38
mxlBrown = 53
mxlOrange = 46
mxlLightOrange = 45
mxlGold = 44
mxlTan = 40
mxlOliveGreen = 52
mxlDarkYellow = 12
mxlLime = 43
mxlYellow = 6
mxlLightYellow = 36
mxlDarkGreen = 51
mxlGreen = 10
mxlSeaGreen = 50
mxlBrightGreen = 4
mxlLightGreen = 35
mxlDarkTeal = 49
mxlTeal = 14
mxlAqua = 42
mxlTurquoise = 8
mxlLightTurquoise = 34
mxlDarkBlue = 11
mxlBlue = 5
mxlLightBlue = 41
mxlSkyBlue = 33
mxlPaleBlue = 37
mxlIndigo = 55
mxlBlueGray = 47
mxlViolet = 13
mxlPlum = 54
mxlLavender = 39
mxlGray80 = 56
mxlGray50 = 16
mxlGray40 = 48
mxlGray25 = 15
mxlWhite = 2
' Chart Fill colors as shown on the color palatte
mxlChartFillPastelBlue = 17
mxlChartFillPlum = 18
mxlChartFillLightTan = 19
mxlChartFillLightTurquoise = 20
mxlChartFillDarkViolet = 21
mxlChartFillPastelPink = 22
mxlChartFillDarkerLightBlue = 23
mxlChartFillLightBueGray = 24
' Chart Line colors as shown on the color palatte
mxlChartLineDarkBlue = 25
mxlChartLinePink = 26
mxlChartLineYellow = 27
mxlChartLineTurquoise = 28
mxlChartLineViolet = 29
mxlChartLineDarkRed = 30
mxlChartLineTeal = 31
mxlChartLineBlue = 32
' Shape scheme colors
mxlSchemeColorBlack = 8
mxlSchemeColorDarkRed = 16
mxlSchemeColorRed = 10
mxlSchemeColorPink = 14
mxlSchemeColorRose = 45
mxlSchemeColorBrown = 60
mxlSchemeColorOrange = 53
mxlSchemeColorLightOrange = 52
mxlSchemeColorGold = 51
mxlSchemeColorTan = 47
mxlSchemeColorOliveGreen = 59
mxlSchemeColorDarkYellow = 19
mxlSchemeColorLime = 50
mxlSchemeColorYellow = 13
mxlSchemeColorLightYellow = 43
mxlSchemeColorDarkGreen = 58
mxlSchemeColorGreen = 17
mxlSchemeColorSeaGreen = 57
mxlSchemeColorBrightGreen = 11
mxlSchemeColorLightGreen = 42
mxlSchemeColorDarkTeal = 56
mxlSchemeColorTeal = 21
mxlSchemeColorAqua = 49
mxlSchemeColorTurquoise = 15
mxlSchemeColorLightTurquoise = 41
mxlSchemeColorDarkBlue = 18
mxlSchemeColorBlue = 12
mxlSchemeColorLightBlue = 48
mxlSchemeColorSkyBlue = 40
mxlSchemeColorPaleBlue = 44
mxlSchemeColorIndigo = 62
mxlSchemeColorBlueGray = 54
mxlSchemeColorViolet = 20
mxlSchemeColorPlum = 61
mxlSchemeColorLavender = 46
mxlSchemeColorGray80 = 63
mxlSchemeColorGray50 = 23
mxlSchemeColorGray40 = 55
mxlSchemeColorGray25 = 22
mxlSchemeColorWhite = 9
End Enum
Public Sub Marker_AddMarkers( _
ByVal TargetRange As Range, _
ByVal ClickRoutineName As String _
)
' Add markers to the range specified by the parameter TargetRange.
Dim Cell As Range
Dim Marker As Shape
For Each Cell In TargetRange
Cell.Font.ColorIndex = IIf(Cell.Interior.ColorIndex = mxlNoColor,
mxlWhite, Cell.Interior.ColorIndex)
If Len(Cell) = 0 Then Cell = False
Set Marker =
TargetRange.Parent.Shapes.AddShape(msoShapeRectangle,
Cell.Left + 2, Cell.Top + 2, Cell.Height - 3.5, Cell.Height - 3.5)
With Marker
.Fill.Solid
.Fill.Transparency = 0
.Line.Weight = 1.5
If Cell.Interior.ColorIndex = mxlGray25 Then
.Line.ForeColor.SchemeColor = mxlSchemeColorGray80
Else
.Line.ForeColor.SchemeColor = mxlSchemeColorGray25
End If
.Fill.ForeColor.SchemeColor = mxlSchemeColorGray50
End With
Marker.OnAction = ClickRoutineName
Next Cell
Marker_SetMarkersInRange TargetRange
End Sub
Public Function Marker_HandleMarkerClick( _
ByVal Marker As Shape _
)
Marker.TopLeftCell = Not Marker.TopLeftCell
Marker.Fill.Visible = IIf(Marker.TopLeftCell, msoTrue, msoFalse)
End Function
Public Sub Marker_SetMarker( _
ByVal Marker As Shape _
)
Marker.Fill.Visible = IIf(Marker.TopLeftCell, msoTrue, msoFalse)
End Sub
Public Sub Marker_SetMarkersInRange( _
ByVal TargetRange As Range _
)
' Set all markers in the range specified by the parameter TargetRange.
Dim Shape As Shape
For Each Shape In TargetRange.Parent.Shapes
If Shape.Type = msoAutoShape Then
If Shape.AutoShapeType = msoShapeRectangle Then
If Not Intersect(TargetRange, Shape.TopLeftCell) Is Nothing Then
Marker_SetMarker Shape
End If
End If
Next Shape
End Sub
a target range on a worksheet and defines the
Shape.Fill.ForeColor.SchemeColor property and the OnAction event. The
OnAction event routine then toggles the Shape.Fill.Visible property on and
off which should change the colour to the already defined
Shape.Fill.ForeColor.SchemeColor property and back again, but the colour
always defaults to turquoise rather than the colour I've specified. The code
detailed below worked fine in Excel 2003, this appears to be a bug in 2007.
--------------------------------------------
Worksheet code (sheet1 in this instance). Run sub TestAddMarkers to add the
worksheet shapes which you can then click to run the OnAction code.
Option Explicit
Public Sub TestAddMarkers()
Marker_AddMarkers Sheet1.Range("A1:A5"), "Sheet1.ToggleMarker"
End Sub
Public Sub ToggleMarker()
Marker_HandleMarkerClick Sheet1.Shapes(Application.Caller)
Marker_SetMarkersInRange Sheet1.Range("A1:A5")
End Sub
-----------------------------------------------
Module level code detailed below...
Option Explicit
Public Enum tColorIndex
' Colors are in same order as on color pallete, down and across
mxlAutomaticColor = 0
mxlNoColor = -4142
mxlBlack = 1
mxlDarkRed = 9
mxlRed = 3
mxlPink = 7
mxlRose = 38
mxlBrown = 53
mxlOrange = 46
mxlLightOrange = 45
mxlGold = 44
mxlTan = 40
mxlOliveGreen = 52
mxlDarkYellow = 12
mxlLime = 43
mxlYellow = 6
mxlLightYellow = 36
mxlDarkGreen = 51
mxlGreen = 10
mxlSeaGreen = 50
mxlBrightGreen = 4
mxlLightGreen = 35
mxlDarkTeal = 49
mxlTeal = 14
mxlAqua = 42
mxlTurquoise = 8
mxlLightTurquoise = 34
mxlDarkBlue = 11
mxlBlue = 5
mxlLightBlue = 41
mxlSkyBlue = 33
mxlPaleBlue = 37
mxlIndigo = 55
mxlBlueGray = 47
mxlViolet = 13
mxlPlum = 54
mxlLavender = 39
mxlGray80 = 56
mxlGray50 = 16
mxlGray40 = 48
mxlGray25 = 15
mxlWhite = 2
' Chart Fill colors as shown on the color palatte
mxlChartFillPastelBlue = 17
mxlChartFillPlum = 18
mxlChartFillLightTan = 19
mxlChartFillLightTurquoise = 20
mxlChartFillDarkViolet = 21
mxlChartFillPastelPink = 22
mxlChartFillDarkerLightBlue = 23
mxlChartFillLightBueGray = 24
' Chart Line colors as shown on the color palatte
mxlChartLineDarkBlue = 25
mxlChartLinePink = 26
mxlChartLineYellow = 27
mxlChartLineTurquoise = 28
mxlChartLineViolet = 29
mxlChartLineDarkRed = 30
mxlChartLineTeal = 31
mxlChartLineBlue = 32
' Shape scheme colors
mxlSchemeColorBlack = 8
mxlSchemeColorDarkRed = 16
mxlSchemeColorRed = 10
mxlSchemeColorPink = 14
mxlSchemeColorRose = 45
mxlSchemeColorBrown = 60
mxlSchemeColorOrange = 53
mxlSchemeColorLightOrange = 52
mxlSchemeColorGold = 51
mxlSchemeColorTan = 47
mxlSchemeColorOliveGreen = 59
mxlSchemeColorDarkYellow = 19
mxlSchemeColorLime = 50
mxlSchemeColorYellow = 13
mxlSchemeColorLightYellow = 43
mxlSchemeColorDarkGreen = 58
mxlSchemeColorGreen = 17
mxlSchemeColorSeaGreen = 57
mxlSchemeColorBrightGreen = 11
mxlSchemeColorLightGreen = 42
mxlSchemeColorDarkTeal = 56
mxlSchemeColorTeal = 21
mxlSchemeColorAqua = 49
mxlSchemeColorTurquoise = 15
mxlSchemeColorLightTurquoise = 41
mxlSchemeColorDarkBlue = 18
mxlSchemeColorBlue = 12
mxlSchemeColorLightBlue = 48
mxlSchemeColorSkyBlue = 40
mxlSchemeColorPaleBlue = 44
mxlSchemeColorIndigo = 62
mxlSchemeColorBlueGray = 54
mxlSchemeColorViolet = 20
mxlSchemeColorPlum = 61
mxlSchemeColorLavender = 46
mxlSchemeColorGray80 = 63
mxlSchemeColorGray50 = 23
mxlSchemeColorGray40 = 55
mxlSchemeColorGray25 = 22
mxlSchemeColorWhite = 9
End Enum
Public Sub Marker_AddMarkers( _
ByVal TargetRange As Range, _
ByVal ClickRoutineName As String _
)
' Add markers to the range specified by the parameter TargetRange.
Dim Cell As Range
Dim Marker As Shape
For Each Cell In TargetRange
Cell.Font.ColorIndex = IIf(Cell.Interior.ColorIndex = mxlNoColor,
mxlWhite, Cell.Interior.ColorIndex)
If Len(Cell) = 0 Then Cell = False
Set Marker =
TargetRange.Parent.Shapes.AddShape(msoShapeRectangle,
Cell.Left + 2, Cell.Top + 2, Cell.Height - 3.5, Cell.Height - 3.5)
With Marker
.Fill.Solid
.Fill.Transparency = 0
.Line.Weight = 1.5
If Cell.Interior.ColorIndex = mxlGray25 Then
.Line.ForeColor.SchemeColor = mxlSchemeColorGray80
Else
.Line.ForeColor.SchemeColor = mxlSchemeColorGray25
End If
.Fill.ForeColor.SchemeColor = mxlSchemeColorGray50
End With
Marker.OnAction = ClickRoutineName
Next Cell
Marker_SetMarkersInRange TargetRange
End Sub
Public Function Marker_HandleMarkerClick( _
ByVal Marker As Shape _
)
Marker.TopLeftCell = Not Marker.TopLeftCell
Marker.Fill.Visible = IIf(Marker.TopLeftCell, msoTrue, msoFalse)
End Function
Public Sub Marker_SetMarker( _
ByVal Marker As Shape _
)
Marker.Fill.Visible = IIf(Marker.TopLeftCell, msoTrue, msoFalse)
End Sub
Public Sub Marker_SetMarkersInRange( _
ByVal TargetRange As Range _
)
' Set all markers in the range specified by the parameter TargetRange.
Dim Shape As Shape
For Each Shape In TargetRange.Parent.Shapes
If Shape.Type = msoAutoShape Then
If Shape.AutoShapeType = msoShapeRectangle Then
If Not Intersect(TargetRange, Shape.TopLeftCell) Is Nothing Then
Marker_SetMarker Shape
End If
End If
Next Shape
End Sub