OnTime less than 1 second without responding to requests
I have a custom form that runs a script every 100ms. The script processes the images in the custom form and is used to animate them, while the form continues to receive user input (mouse clicks and keystrokes). This continues until the userform is closed. While Application.OnTime seems to work best, it only works sequentially with time values of 1 second or more.
When I use something like
Sub StartTimer()
Application.OnTime now + (TimeValue("00:00:01") / 10), "Timer"
End Sub
Private Sub Timer()
TheUserForm.ScreenUpdate
Application.OnTime now + (TimeValue("00:00:01") / 10), "Timer"
End Sub
and call StartTimer on a custom form, Excel becomes very irrelevant, and Timer is called many more times per second than it needs to.
Using the Sleep function causes the program to become unresponsive as well, even though the script runs at the correct interval.
Is there a workaround for this? Thanks in advance!
source to share
OnTime
can only be scheduled in 1 second increments. When you try to schedule it for 1 / 10th of a second, you actually schedule for 0 seconds, meaning it starts up again immediately, consuming all resources.
Short answer: you cannot use OnTime
to trigger an event every 1/10 of a second.
There are other ways, see CPearson for using the Windows API callPublic Declare Function SetTimer Lib "user32"...
source to share
Try this simple hybrid method for your Timer:
Sub Timer
Application.OnTime now + TimeValue("00:00:01"), "Timer"
t1 = Timer
Do Until Timer >= t1 + 0.9
t2 = Timer
Do Until Timer >= t2 + 0.1
DoEvents
Loop
TheUserForm.ScreenUpdate
... your code
Loop
End Sub
Of course, one user problem with the Timer function is that your code can turn into a pumpkin (or crash) at midnight.;) You would need to make it smarter, but if you usually only work during the day like me, It's not a problem.
source to share
' yes it is a problem
' it stops when cell input occurs or an cancel = false dblClick
' the timer API generally bombs out EXCEL on these
' or program errors as VBA has no control over them
' this seems to work and is in a format hopefully easy to adapt to
' many simultaneous timed JOBS even an Array of Jobs.. will try it this week
' Harry
Option Explicit
Public RunWhen#, PopIntervalDays#, StopTime#
Public GiveUpDays#, GiveUpWhen#, PopTimesec#, TotalRunSec!
Public PopCount&
Public Const cRunWhat = "DoJob" ' the name of the procedure to run
Sub SetTimerJ1(Optional Timesec! = 1.2, Optional RunForSec! = 10, Optional GiveUpSec! = 20)
If Timesec < 0.04 Then Timesec = 0.05
' does about 150 per sec at .05 "
' does 50 per sec at .6 ????????????
' does 4 per sec at .9 ????????????
'iterations per sec =185-200 * Timesec ( .1 < t < .9 )
' if t >1 as int(t)
' or set Timesec about (iterationsNeeded -185)/200
'
PopTimesec = Timesec
PopIntervalDays = PopTimesec / 86400# ' in days
StopTime = Now + RunForSec / 86400#
GiveUpDays = GiveUpSec / 86400#
TotalRunSec = 0
PopCount = 0
StartTimerDoJob
End Sub
Sub StartTimerDoJob()
RunWhen = Now + PopIntervalDays
GiveUpWhen = Now + GiveUpDays
Application.OnTime RunWhen, cRunWhat, GiveUpWhen
' Cells(2, 2) = Format(" At " & Now, "yyyy/mm/dd hh:mm:ss")
'Application.OnTime EarliestTime:=Now + PopTime, Procedure:=cRunWhat, _
Schedule:=True
End Sub
Sub DoJob()
DoEvents
PopCount = PopCount + 1
'Cells(8, 2) = PopCount
If Now >= StopTime - PopIntervalDays / 2 Then ' quit DoJob
On Error Resume Next
Application.OnTime RunWhen, cRunWhat, , False
Else
StartTimerDoJob ' do again
End If
End Sub
Sub StopTimerJ1()
On Error Resume Next
Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
schedule:=False
End Sub
source to share
I had the same question today. Here the solution I was able to find worked really well. This allows the event to be synchronized at just 1 millisecond intervals without taking control of the application or causing it to crash.
The only flaw I have been able to find is that it TimerEvent()
requires complete TimerEvent()
On Error Resume Next
to ignore errors caused by the fact that it cannot execute the code (for example, when you edit another cell), which means that it will have no idea when a legitimate error occurs.
Public Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, _
ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, _
ByVal nIDEvent As Long) As Long
Public TimerID As Long
Sub StartTimer()
' Run TimerEvent every 100/1000s of a second
TimerID = SetTimer(0, 0, 100, AddressOf TimerEvent)
End Sub
Sub StopTimer()
KillTimer 0, TimerID
End Sub
Sub TimerEvent()
On Error Resume Next
Cells(1, 1).Value = Cells(1, 1).Value + 1
End Sub
source to share