OnTime for less than 1 second without becoming Unresponsive

问题

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 (mouse clicks and key presses). This continues until the userform is closed. While Application.OnTime seems to work best, it only operates consistently on 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 in the userform, Excel becomes very unresponsive and "Timer" is called many more times per second than it should.

Using the Sleep function causes the program to become unresponsive too, although the script is run with the right interval.

Is there a workaround for this? Thanks in advance!

回答1:

OnTime can only be scheduled to run in increments of 1 second. When you attempt to schedule it at 1/10th second, you actually schedule at 0 seconds, ie it runs again immediately, consuming all resources.

Short answer, you cannot use OnTime to run an event every 1/10 second.

There are other ways, see CPearson for using a call to Windows API
Public Declare Function SetTimer Lib "user32" ...

回答2:

Try this simple hybrid method for your 'Timer' sub:

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 problem of user the 'Timer' function is that at midnight your code may turn into a pumpkin (or crash). ;) You would need to make this smarter but if you generally only work during the day, like me, it's not a problem.

回答3:

Just had this same question today. Here's the solution I was able to find that worked really well. It allows a timed event to fire on intervals as small as 1 millisecond, without taking control of the application or causing it to crash.

The one disadvantage I've been able to find is that TimerEvent() requires a blanket On Error Resume Next to ignore errors caused when it can't execute the code (like when you're editing another cell), which means it will have no idea when a legitimate error occurs.

Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, _ 
    ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, _
    ByVal nIDEvent As LongPtr) 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

回答4:

' 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

来源：https://stackoverflow.com/questions/25116231/ontime-for-less-than-1-second-without-becoming-unresponsive

标签

excel

vba

sleep

ontime