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

Posted 2023-02-19

【中文标题】OnTime 不到 1 秒而没有变得无响应

【英文标题】：OnTime for less than 1 second without becoming Unresponsive

【发布时间】：2014-09-26 18:46:26

【问题描述】：

我有一个用户表单，它每 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”的次数比它应该调用的次数多。

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

有解决办法吗？提前致谢！

【参考方案1】：

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

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

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

【讨论】：

使用来自内核库的sleep()：Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)。 *zzz...*

@peter_the_oak OP 已经表示他尝试过Sleep 没有成功

@chrisneilsen 谢谢，您的解决方案运行良好。似乎使用 Windows 计时器是可行的方法！

我为不到 1 秒的时间道歉，它做了 Sub 多次

它可能会在 10 秒内说 300 次迭代，但它会在 1 秒内爆发，它确实在一秒的前 0.01 秒内说 30 次，然后等待到秒结束......什么都不做0.99 秒。每 10 秒重复一次……

【参考方案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 

当然，使用“定时器”功能的一个问题是，在午夜，您的代码可能会变成南瓜（或崩溃）。 ;) 你需要让它变得更聪明，但如果你像我一样通常只在白天工作，那不是问题。

【参考方案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

【讨论】：

请注意，您使用的是 Office 2010 之前的 API 声明（如果您也必须使用它们，请考虑通过 #If VBA7 Then 进行条件编译）。如果没有，只需使用：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" Alias "KillTimer" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long 并注意通过 Public TimerID As LongPtr 将 TimerID 声明为 LongPtr。

@T.M.我认为这与 Office 年份本身无关，而是与您使用的是 32 位 Excel 还是 64 位 Excel 有关。我假设是 32 位，因为这仍然是最常见的，即使对于我正在使用的 Excel 2016 也是如此。但是，如果它是 64 位 Excel，那么您是正确的。如果明天有机会，我会尝试将其添加到我的答案中，谢谢！

AFAIK 在大多数情况下，使用 Office 2010 和 更高版本 作为提到的（以及大多数其他更新的）指针安全声明是安全的支持两种 32 位和 64 位版本的 Windows 上的 API 调用，并可通过#If VBA7 ... 进行检查；只有少数类型语句声明需要明确检查 64 位和 32 位 (#If Win64 ...)。

相关链接： API Declarations 32/64 bit Office保存到文件夹C:\Office 2010 Developer Resources\Documents\Office2010Win32API_PtrSafe)，和Declaring API functions in 64 bit Office

@T.M.，我没有意识到 VBA7 直到 Office 2010 才出现，所以你的 cmets 是完全正确的。我也没有意识到 PtrSafe 不需要 #If 用于 2010 年或更高版本，因为我上次搞砸了我使用的是 2007 年。你们这些 cmets 真的很有帮助！我已经相应地更新了我的答案。

【参考方案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