Prev: importing multiple text files into Excel with corresponding fi
Next: select range in column, calculate on range plus 3 columns, output inrange plus 7 columns
From: jamesdbrown1979 on 3 Feb 2010 11:51 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.
From: minimaster on 4 Feb 2010 05:05 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 .....
From: jamesdbrown1979 on 4 Feb 2010 07:00 "minimaster" wrote: > 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.
From: minimaster on 6 Feb 2010 07:20 Posting your code might be helpful.
From: jamesdbrown1979 on 8 Feb 2010 06:23
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 |