Excel VBA的OnTime不到1秒，没有变得没有反应

我有一个用户表单，每100ms运行一个脚本。 该脚本处理用户窗体上的图像，并用于对它们进行animation处理，而窗体继续接收用户input（鼠标点击和按键）。 这一直持续到用户表单closures。 虽然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”每秒被调用的次数比它应该多。

尽pipe脚本以正确的间隔运行，但使用睡眠function也会导致程序无响应。

有没有解决方法？ 提前致谢！

Answer 1

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

简短的回答，你不能使用OnTime每1/10秒运行一个事件。

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

Answer 2

尝试这个简单的混合方法为您的'计时器'子：

 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 

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

Answer 3

 ' 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