OnTime for less than 1 second without becoming Unresponsive

Question

I have a userform which runs a script every 100ms. The script handles images on the userform and is used to animate them, while the form continues to receive user input (mou

Answer 1

' 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