excel - 使用 Application.OnTime 的调度和重复出现问题

Question

我想制作一个在后台循环运行的程序，并在可刷新的查询上运行，而不会同时挂起 excel，当发生错误时，它会显示一条消息。
因此，对我有用的唯一想法是使用 Application.Ontime 安排一个过程 - 函数告诉自己何时再次运行，当我在 Excel 工作表中调整 slider 时它会停止。
但是我有一个我无法理解的问题:
为什么这个messageBox每次都显示两次？第一条消息告诉它是(现在)时间，第二条消息告诉它是(现在+20)时间。

Public Sub sendingAmessage(schTime As Date)


If Worksheets("MAIN").Range("ToggleText").Value = "MONITORING ON" Then
    
    AppActivate Application.Caption
    MsgBox (schTime)
    
    Application.OnTime schTime, "'sendingAmessage""" & DateAdd("s", 20, Now) & "'"
End If

End Sub

Answer 1

以下是如何重新安排或重复出现 OnTime 事件的示例。只需查看当您调用程序时，您需要从程序中调用 OnTime 子程序。

Public RunWhen As Double
Public Const cRunIntervalSeconds = 1
Public Const cRunWhat = "TheSub"  ' the name of the procedure to run
Public Password As String


' See top of Module to see public Variable and Constants
Sub StartTimer()
    RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
        Schedule:=True
End Sub

Sub TheSub()
    ' Set Cell A1 to the Current Time
    ActiveSheet.Range("A1") = Time
    StartTimer  ' Reschedule the procedure
End Sub

Sub StopTimer()
    On Error Resume Next
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
        Schedule:=False
End Sub

如果您还想尝试 Windows API 方法，请参见下文:
请注意，有时试图取消它是挑剔的。如果它确实首先保存所有内容，然后如果您关闭工作簿，则操作系统中 excel 之外的进程将杀死(forceclose)excel，以及如果您调用错误的过程，如下所述。

' Windows Timer functions via Windows API
' PtrSafe needed for API to work
' LongPtr is safe versions for 64 and 32 bit systems
' It converts between Long and LongLong types accordingly
' Note when an incorrect pointer is listed excel will likely crash
' If error External Error-Handlers will look to OS for help and kill excel.exe

Option Explicit
Public Declare PtrSafe Function SetTimer Lib "user32" ( _
    ByVal HWnd As LongPtr, _
    ByVal nIDEvent As LongPtr, _
    ByVal uElapse As LongPtr, _
    ByVal lpTimerFunc As LongPtr) As Long

Public Declare PtrSafe Function KillTimer Lib "user32" ( _
    ByVal HWnd As LongPtr, _
    ByVal nIDEvent As LongPtr) As Long

Public TimerID As Long
Public TimerSeconds As Single
Public bTimerEnabled As Boolean
Public iCounter As Single
Public bComplete As Boolean

Public EventType As Integer

Sub StartTimer()
    iCounter = 2
    TimerID = SetTimer(0&, 0&, iCounter * 1000&, AddressOf TimerProc)
End Sub

Sub EndTimer()
    KillTimer 0&, TimerID
    bTimerEnabled = False
    bComplete = True
End Sub

Sub TimerProc(ByVal HWnd As LongPtr, ByVal uMsg As LongPtr, _
    ByVal nIDEvent As LongPtr, ByVal dwTimer As LongPtr)
    Dim rc As Double

    On Error Resume Next
    Debug.Print iCounter
    ' Continue
    If iCounter <= 60 Then
        rc = On_Time.Range("F1045000").End(xlUp).Row + 1
        On_Time.Range("F" & rc) = Time
        ThisWorkbook.Save
    End If
    
    ' EndTimer
    If iCounter > 60 Then
        EndTimer
    End If

    iCounter = iCounter + 1
End Sub