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

ashni

New Member
Joined
Jun 13, 2016
Messages
32
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.

Code:
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

Well-known Member
Joined
Jun 2, 2016
Messages
3,401
You only call StartTimer if there is no shape selected. Is that your intention?

WBD
 

ashni

New Member
Joined
Jun 13, 2016
Messages
32
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

Well-known Member
Joined
Jun 2, 2016
Messages
3,401
I think you're nearly there. Try this:

Code:
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
 

Forum statistics

Threads
1,081,860
Messages
5,361,737
Members
400,653
Latest member
ProParadox

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top