Run a macro to update selected shape color after every 3 seconds

[ashni]

I want this macro to run after every 3 seconds so that each time i move a selected shape among many shapes its color should change.
But this code only works once... It doesn't repeat or doesn't change the color of next shape i select and move to particular position.


Sub UpdateColor()
Dim ActiveShape As Shape
Dim UserSelection As Variant
Dim d As Integer
Set UserSelection = ActiveWindow.Selection
On Error GoTo NoShapeSelected
Set ActiveShape = ActiveSheet.Shapes(UserSelection.Name)
On Error Resume Next
With ActiveShape
d = ActiveShape.Left
If d >= 0 And d <= 123.5 Then
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 128, 0)
ElseIf d >= 124 And d <= 336.75 Then
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 102, 204)
ElseIf d >= 336.76 And d <= 547.5 Then
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 153, 0)
ElseIf d >= 547.51 And d <= 776.25 Then
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(219, 38, 10)
ElseIf d >= 776.25 Then
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(211, 211, 211)
End If
End With
Exit Sub
NoShapeSelected:
MsgBox "You do not have a shape selected!"

Application.OnTime Now + TimeValue("00:00:03"), "GetPosition3"
End Sub


Please tell me what is wrong with the code.

 

[baitmaster]

Application.OnTime Now + TimeValue("00:00:03"), "GetPosition3"

is calling a piece of code named "GetPosition3", whereas this code is named "UpdateColor". That's one reason why it's not repeating. The other is that it appears after the Exit Sub, so it will only ever configure to run again after you encounter an error

There are some dangers to using self-calling code, for example having the ability to switch it off again. You should assign the time value to a public variable so that you can end it again when you want, and cancel any planned code runs that are in the system - especially if they happen every 3 seconds and involve a pop-up message. Did you know for example, that if you close this file but not Excel, this code will reopen the file in order to run it again? That could get reeeeally annoying...

A couple of other things wrong with the code too. d is defined as an integer but uses decimals so you'll get a type mismatch error. I wouldn't close an ON ERROR step with on error resume next as all further error will be hidden: better to use on error goto 0 so you know about any other problems. You have a WITH / END WITH that you're not using. You have various objects that you're not using and are just confusing your code - ActiveShape is only used to help generate errors, and UserSelection is unnecessary

If I were doing this, I'd change things as follows

Option Explicit

Dim dtRunTme As Date
Const strTime As String = "00:00:03"

Sub UpdateColor()
Dim d As Double

' create error if selection does not involve a shape
On Error GoTo NoShapeSelected
    d = Selection.ShapeRange.Fill.ForeColor
On Error GoTo 0

' amend colour based on selection.left
d = Selection.Left

If d >= 0 And d <= 123.5 Then
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 128, 0)
ElseIf d >= 124 And d <= 336.75 Then
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 102, 204)
ElseIf d >= 336.76 And d <= 547.5 Then
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 153, 0)
ElseIf d >= 547.51 And d <= 776.25 Then
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(219, 38, 10)
ElseIf d >= 776.25 Then
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(211, 211, 211)
End If

NoShapeSelected:

' configure routine to run again
dtRunTme = Now + TimeValue(strTime)
Application.OnTime earliesttime:=dtRunTme, procedure:="UpdateColor", schedule:=True

End Sub

Sub autoRoutineOff()
On Error Resume Next ' in case not scheduled
    Application.OnTime earliesttime:=dtRunTme, procedure:="UpdateColor", schedule:=False
On Error GoTo 0
End Sub

 

[ashni]

Thank you so much baitmaster!!! I am a newbie !! I do a lot of mistakes.
And you just saved me!! Your code is working great!!

 

[baitmaster]

Don't worry, I've made more than my fair share of mistakes over the years!

One other thing that I'd do is simplify the repeated IF ELSEIF structure. When you have multiple conditions you can use SELECT CASE instead, which is really useful where you want several options to do one thing, and several to do another. The following 2 pieces of code should do the same thing

If d >= 0 And d <= 123.5 Then
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 128, 0)
ElseIf d >= 124 And d <= 336.75 Then
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 102, 204)
ElseIf d >= 336.76 And d <= 547.5 Then
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 153, 0)
ElseIf d >= 547.51 And d <= 776.25 Then
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(219, 38, 10)
ElseIf d >= 776.25 Then
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(211, 211, 211)
End If

Dim colour As Long
Select Case d
    Case Is < 124: colour = RGB(255, 128, 0)
    Case Is < 337: colour = RGB(0, 102, 204)
    Case Is < 548: colour = RGB(0, 153, 0)
    Case Is < 777: colour = RGB(219, 38, 10)
    Case Else: colour = RGB(211, 211, 211)
End Select

Selection.ShapeRange.Fill.ForeColor.RGB = colour

 

[ashni]

WOw!!!
Saved many lines of code!!