jamesdbrown1979
2/8/2010 11:23:00 AM
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()
Dim Count As Long
Dim MarkerCount As Long
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