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.

Public RunWhen As Double
Public Const cRunIntervalSeconds = 2
Public Const cRunWhat = "UpdateColor"


Sub StartTimer()
RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, _
     schedule:=True
End Sub


Sub StopTimer()
   On Error Resume Next
   Application.OnTime earliesttime:=RunWhen, _
       procedure:=cRunWhat, schedule:=False
End Sub


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!"


Call StartTimer
End Sub

Please someone help me out.

 

[wideboydixon]

You only call StartTimer if there is no shape selected. Is that your intention?

WBD

 

[ashni]

My intention is to call StartTimer only once. And after that whenever i move any shape among say 10 shapes the shape color should change according to its position.
I should not have to click on say-UpdateColor button everytime i move it.

 

[wideboydixon]

I think you're nearly there. Try this:

Public Const cRunIntervalSeconds = 2
Public Const cRunWhat = "UpdateColor"
Public RunWhen As Variant
Public TimerStarted As Boolean
Sub StartTimer()

    RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
    Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, schedule:=True
    TimerStarted = True
    
End Sub
Sub StopTimer()

    On Error Resume Next
    Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, schedule:=False
    TimerStarted = False
   
End Sub
Sub UpdateColor()

    Dim ActiveShape As Shape
    Dim UserSelection As Variant
    Dim shapeLeft As Single
    
    Set UserSelection = ActiveWindow.Selection
    On Error Resume Next
    Err.Clear
    Set ActiveShape = ActiveSheet.Shapes(UserSelection.Name)
    
    If Err.Number = 0 Then
        With ActiveShape
            shapeLeft = ActiveShape.Left
            If shapeLeft >= 0 And shapeLeft <= 123.5 Then
                Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 128, 0)
            ElseIf shapeLeft >= 124 And shapeLeft <= 336.75 Then
                Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 102, 204)
            ElseIf shapeLeft >= 336.76 And shapeLeft <= 547.5 Then
                Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 153, 0)
            ElseIf shapeLeft >= 547.51 And shapeLeft <= 776.25 Then
                Selection.ShapeRange.Fill.ForeColor.RGB = RGB(219, 38, 10)
            ElseIf shapeLeft >= 776.25 Then
                Selection.ShapeRange.Fill.ForeColor.RGB = RGB(211, 211, 211)
            End If
        End With
    End If
    
    If TimerStarted Then Call StartTimer

End Sub

Call StartTimer to start it checking. Call StopTimer to stop it. I tested this out on a worksheet and it seemed to work as intended I think. I took out the MessageBox because I thought that would be very annoying

WBD