Question

我有一个每100毫秒运行一次脚本的用户窗体。该脚本处理用户窗体上的图像并用于为它们设置动画，同时窗体继续接收用户输入（鼠标单击和按键）。这将一直持续到用户窗体关闭为止。虽然Application.OnTime似乎效果最好，但它只能在1秒或更长的时间值上一致地运行。

当我使用像

这样的东西时

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

并在用户窗体中调用StartTimer，Excel变得非常无响应，每秒调用“Timer”的次数超过应有的次数。

使用Sleep功能会导致程序无响应，尽管脚本以正确的间隔运行。

有解决方法吗？提前谢谢！

Answer 1

OnTime只能安排以1秒为增量运行。当您尝试在1/10秒安排它时，实际上计划在0秒，即它立即再次运行，消耗所有资源。

简短回答，无法使用OnTime每1/10秒运行一次事件。

还有其他方法，请参阅CPearson以使用对Windows API的调用 Public Declare Function SetTimer Lib "user32" ...

Answer 2

为'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

当然，用户“计时器”功能的一个问题是午夜你的代码可能变成南瓜（或崩溃）。 ;）你需要更聪明，但如果你一般只在白天工作，像我一样，这不是问题。

Answer 3

今天也有同样的问题。这是我能够找到的效果很好的解决方案。它允许定时事件以小于1毫秒的间隔触发，而无需控制应用程序或导致应用程序崩溃。

我能够找到的一个缺点是TimerEvent()需要一个覆盖On Error Resume Next来忽略它无法执行代码（例如，当您编辑另一个单元格时）引起的错误。，这意味着何时发生合法错误都不知道。

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

Answer 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

OnTime不到1秒而没有变得无法响应

4 个答案: