Auto shape color change

[Juriemagic]

Hi good people!,

I found this code:
Dim shp As Shape, r As Long, g As Long, b As Long

With Sheet1
For Each shp In .Shapes
With shp.TextFrame
Select Case .Characters.Text
Case "1"
r = 255
g = 0
b = 0
Case "2"
r = 0
g = 255
b = 0
End Select
End With
shp.Fill.ForeColor.RGB = RGB(r, g, b)
Next shp
End With



I have implemented this code in two sheets. It works perfectly in sheet3, but errors in sheet6..Would someone please be so kind to check why this is so?...Thank you all kindly..

[Paul_Hossler]

Spin buttons and scrollbars and charts don't have a textframe with characters

You could add error handling (e.g. On Error Resume Next) or catch the shape type (below)



Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim shp As Shape, r As Long, g As Long, b As Long
With Sheet6
For Each shp In .Shapes
If shp.Type = msoOLEControlObject Then GoTo GetNextShape
If shp.Type = msoChart Then GoTo GetNextShape

With shp.TextFrame
Select Case .Characters.Text
Case "1"
r = 255
g = 0
b = 0
Case "2"
r = 0
g = 255
b = 0
End Select
End With

shp.Fill.ForeColor.RGB = RGB(r, g, b)

GetNextShape:
Next shp
End With
End Sub




PowerPoint has a .HasTextframe property which would be handy here I think

[Juriemagic]

Hallo Paul_Hossler,

Thank you very much for this help. It wouldn't work using selection change or change, so I put it in a "Calculate" event. It really works great now, UNTILL I select the dropdown in O2...then everything is problematic again...Please my friend, could you kindly have a look at why this happens?...other than this, everything works great!..Thank you very much..

[Paul_Hossler]

Need to add another line to catch that type of shape




Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim shp As Shape, r As Long, g As Long, b As Long
With Sheet6
For Each shp In .Shapes
If shp.Type = msoOLEControlObject Then GoTo GetNextShape
If shp.Type = msoChart Then GoTo GetNextShape
If shp.Type = msoFormControl Then GoTo GetNextShape ' <<<<<<<<<<

With shp.TextFrame
Select Case .Characters.Text
Case "1"
r = 255
g = 0
b = 0
Case "2"
r = 0
g = 255
b = 0
End Select
End With

shp.Fill.ForeColor.RGB = RGB(r, g, b)

GetNextShape:
Next shp
End With
End Sub

[Juriemagic]

Super, thanx a million!!!..have a great day!!

[Aflatoon]

It also looks as though you are only interested in processing the rectangles on that sheet, so you might use:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rect As Rectangle, r As Long, g As Long, b As Long


With Sheet6
For Each rect In .Rectangles
Select Case rect.Text
Case "1"
r = 255
g = 0
b = 0
Case "2"
r = 0
g = 255
b = 0
End Select
rect.Interior.Color = RGB(r, g, b)
Next rect
End With
End Sub

[Juriemagic]

Yes Aflatoon, absolutely right, I did not mention that because I did not want to become a hassle, so I just left it, but I honestly appreciate you looking at this as well and actually taken the time to help me out. This is extremely kind of you. I am most certainly going to implement this extra coding...Thank you very much!

Just something if I may...would this change also prevent the Textbox to NOT format?, if not, is there a way to exclude the textbox as well?..

[Aflatoon]

It will only process rectangles, not textboxes or anything else.

[Juriemagic]

You have been a great help..Thank you Aflatoon..

[Paul_Hossler]

Yes Aflatoon, absolutely right, I did not mention that because I did not want to become a hassle,..

Actually that would have made it easier and more robust as Aflatoon demonstrated

Always better to provide too much instead of not enough information

[Juriemagic]

You're right Paul_Hossler, but it was ..to be honest, not a major matter, it was something I could live with, but since Aflatoon pointed that out, well, why not use it, it does look better. Thanx for your input...

[Aflatoon]

Always better to provide too much instead of not enough information

Generally I agree but sometimes too much information leads to TLDR. ;)

[Juriemagic]

:)

[Paul_Hossler]

Generally I agree but sometimes too much information leads to TLDR. ;)

I had to look that up :rofl:

[Juriemagic]

Haha..I pretended to know, but I also looked that up...never to old to learn something, even if it's not VBA.. :laugh2: