Excel 2007 VBA shape fill colour problem

[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. This code
worked fine in Excel 2003 - any guidance would be greatly appreciated.

 

[minimaster]

In Excel shape objects can be given basically any color independent of
the Excel color palette (56 colors) and independent of the 80 Scheme
colors. This was already possible in Excel versions prior to 2007.

This means you might be able to solve your problem by just assigning a
color value directly to the RGB property of the fill object.
Its a long time since I worked with the colors of shape objects but I
see in my old code that for assigning a color I had to do some
deselecting and selecing again to work with the buil-in Excel dialog
xlDialogEditColor
That might not be neccessary in your case.

Here a short code snippet that shows you how I do change the color of
a shape object. Still works in XL2007
.....
dim NewColor as long
.....
Select Case TypeName(Selection)
Case "Rectangle", "Oval", "TextBox", "Drawing"
On Error GoTo err_hdl
Set shpR = Selection.ShapeRange
On Error GoTo 0
'we can't start the Dialogs(xlDialogEditColor) when a
shape is selected so therefore
' some code to activate the worksheet while we go to the
dialog
ActiveWorkbook.Windows(1).Activate
If ActiveSheet.Type = xlWorksheet Then
shpR.Item(1).TopLeftCell.Select
End If
newColor = PickNewColor(CDbl(colStart), colID, True) ' my
custom function to handle xlDialogEditColor
shpR.Select
With shpR.Fill
.ForeColor.RGB = newColor
End With
end select
.....

 

[jamesdbrown1979]

In Excel shape objects can be given basically any color independent of
the Excel color palette (56 colors) and independent of the 80 Scheme
colors. This was already possible in Excel versions prior to 2007.

This means you might be able to solve your problem by just assigning a
color value directly to the RGB property of the fill object.
Its a long time since I worked with the colors of shape objects but I
see in my old code that for assigning a color I had to do some
deselecting and selecing again to work with the buil-in Excel dialog
xlDialogEditColor
That might not be neccessary in your case.

Here a short code snippet that shows you how I do change the color of
a shape object. Still works in XL2007
.....
dim NewColor as long
.....
Select Case TypeName(Selection)
Case "Rectangle", "Oval", "TextBox", "Drawing"
On Error GoTo err_hdl
Set shpR = Selection.ShapeRange
On Error GoTo 0
'we can't start the Dialogs(xlDialogEditColor) when a
shape is selected so therefore
' some code to activate the worksheet while we go to the
dialog
ActiveWorkbook.Windows(1).Activate
If ActiveSheet.Type = xlWorksheet Then
shpR.Item(1).TopLeftCell.Select
End If
newColor = PickNewColor(CDbl(colStart), colID, True) ' my
custom function to handle xlDialogEditColor
shpR.Select
With shpR.Fill
.ForeColor.RGB = newColor
End With
end select
.....
.

I can successfully change the shape fill colour at runtime, this is not the
problem. I am setting the Shape.Fill.ForeColor.SchemeColor property when I
originally add a shape to worksheet range. I then enable/disable the
Shape.Fill.Visible property to change the colour back and forth when a user
clicks on the shape using the OnAction event. The problem i'm experiencing is
the shape doesn't change to the colour i've originally set in the
Shape.Fill.ForeColor.SchemeColor property, it simply defaults to turquoise
all the time. As already stated, this code worked fine in 2003. I can post
all related code if this helps, but this appears to be a bug in 2007.

 

[minimaster]

Posting your code might be helpful.

 

[jamesdbrown1979]

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