5

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

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

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

4

4 回答 4

3

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

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

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

于 2014-08-04T10:27:03.873 回答
1

今天刚问了同样的问题。这是我能够找到的非常有效的解决方案。它允许定时事件以小至 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
于 2019-03-28T16:33:28.027 回答
1

为您的“计时器”子尝试这种简单的混合方法：

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

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

于 2015-11-17T16:15:10.757 回答
0 
' 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
于 2016-12-29T23:03:45.207 回答