对象“应用程序”的“ONTIME”方法Application.Ontime取消失败

Question

我是完全失去了，所以任何帮助都会非常感谢。

我试图取消在打开工作簿时触发并使用Application.Ontime方法重复执行的2个预定事件。

我知道要终止OnTime调度循环，您必须提供计划运行的确切时间，而拥有多个Application.OnTime任务需要多个变量。这就是为什么我设置了两个公共变量(选项下面的文档标题显式)：

Dim dTime as Date
Dim dTime2 as Date

调度程序使用这些变量，并且在代码每分钟运行时一切都正常工作。

dTime的值在TaskTracker函数中设置为：

dTime = Now() + TimeValue("00:01:00")
Application.OnTime dTime, "TaskTracker", , True

dTime2的值在自动核函数中设置为：

dTime2 = Now() + TimeValue("00:01:00")
Application.OnTime dTime, "AutoClear", , True

尽管如此，在试图在模块末尾运行函数时，我还是会得到对象“应用程序”错误消息的“ONTIME”方法：

Function AutoDeactivate()
Application.OnTime EarliestTime:=dTime, Procedure:="TaskTracker", _
    Schedule:=False
Application.OnTime EarliestTime:=dTime2, Procedure:="AutoClear", _
    Schedule:=False
End Function

这是我绝对不明白出了什么问题的地方。触发调试将使我看到每个过程取消尝试的OnTime部分。

下面是包含这些元素的脚本。希望这将给你们一些洞察力，为什么这些活动不能取消。

Option Explicit
Dim dTime As Date
Dim dTime2 As Date

'------------------------------------------------------------
'This is what checks cells to define if an email notification has to be sent, and what the content of that email should be.
'------------------------------------------------------------
Function TaskTracker()
Dim FormulaCell     As Range
Dim FormulaRange    As Range
Dim NotSentMsg      As String
Dim MyMsg           As String
Dim SentMsg         As String
Dim SendTo          As String
Dim CCTo            As String
Dim BCCTo           As String
Dim MyLimit         As Double
Dim MyLimit2        As Double

dTime = Now() + TimeValue("00:01:00")
NotSentMsg = "Not Sent"
SentMsg = "Sent"
SendTo = ThisWorkbook.Worksheets("Tasks").Range("D2")
CCTo = ThisWorkbook.Worksheets("Tasks").Range("E2")
BCCTo = ThisWorkbook.Worksheets("Tasks").Range("F2")

MyLimit = Date
MyLimit2 = ((Round(Now * 1440, 0) - 30) / 1440)

Set FormulaRange = ThisWorkbook.Worksheets("Tasks").Range("F5:F35")
On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells
    With FormulaCell
            If DateValue(CDate(.Value)) = MyLimit Then
                MyMsg = SentMsg
                If .Offset(0, 1).Value = NotSentMsg Then
                    strTO = SendTo
                    strCC = CCTo
                    strBCC = BCCTo
                    strSub = "[Task Manager] Reminder that you need to: " & Cells(FormulaCell.Row, "B").Value

                If Cells(FormulaCell.Row, "C").Value = "" Then
                        strBody = "Greetings, " & vbNewLine & vbNewLine & _
                        "Your task : " & Cells(FormulaCell.Row, "B").Value & " is nearing its Due Date: " & Cells(FormulaCell.Row, "F").Value & "." & vbNewLine & "A wise decision would be to complete this task before it expires!" & _
                        vbNewLine & vbNewLine & "Truly yours," & vbNewLine & "Task Manager"
                Else
                        strBody = "Hello, " & vbNewLine & vbNewLine & _
                        "Your task : " & Cells(FormulaCell.Row, "B").Value & " with the mention: " & Cells(FormulaCell.Row, "C").Value & " is nearing its Due Date: " & Cells(FormulaCell.Row, "F").Value & "." & vbNewLine & "A wise decision would be to complete this task before it expires!" & _
                        vbNewLine & vbNewLine & "Truly yours," & vbNewLine & "Task Manager"
                End If
        If sendMail(strTO, strSub, strBody, strCC) = True Then MyMsg = SentMsg
        End If

            Else
            MyMsg = NotSentMsg
            End If

            If .Value = MyLimit2 Then
            MyMsg = NotSentMsg
        End If

            Application.EnableEvents = False
            .Offset(0, 1).Value = MyMsg
            Application.EnableEvents = True

    End With

Next FormulaCell

ExitMacro:
Exit Function

EndMacro:
Application.EnableEvents = True

MsgBox "Some Error occurred." _
     & vbLf & Err.Number _
     & vbLf & Err.Description

Application.OnTime dTime, "TaskTracker", , True

End Function
'------------------------------------------------------------
'This is the function that clears the rows of Completed Tasks
'------------------------------------------------------------
Function AutoClear()
Dim i As Integer

dTime2 = Now() + TimeValue("00:01:00")

With Tasks
    For i = 5 To 35
         If .Cells(i, 4).Value Like "Done" And .Cells(i, 5).Value = "1" Then
            .Cells(i, 1).ClearContents
            .Cells(i, 2).ClearContents
            .Cells(i, 3).ClearContents
            .Cells(i, 5).ClearContents
            .Cells(i, 6).ClearContents
            .Cells(i, 4).Value = "Pending"
            .Cells(i, 7).Value = "Not Sent"

        End If
    Next i
End With

Tasks.AutoFilter.ApplyFilter
Application.OnTime dTime2, "AutoClear", , True

End Function
'------------------------------------------------------------
'ThisWorkbook calls this to deactivate the Application.OnTime. This "should" prevent the Excel process from reoppening the worksheets.
'------------------------------------------------------------

Function AutoDeactivate()
On Error Resume Next
Application.OnTime EarliestTime:=dTime, Procedure:="TaskTracker", _
    Schedule:=False
Application.OnTime EarliestTime:=dTime2, Procedure:="AutoClear", _
    Schedule:=False
End Function

Answer 1

看来这是个设置错误！

Option Explicit
Dim dTime As Date
Dim dTime2 As Date

Application.OnTime dTime, "TaskTracker", , True
Application.OnTime dTime2, "AutoClear", , True

使用工作簿关闭时调用的AutoDeactivation函数可以按预期工作！

Function AutoDeactivate()
On Error Resume Next
Application.OnTime EarliestTime:=dTime, Procedure:="TaskTracker", _
Schedule:=False
Application.OnTime EarliestTime:=dTime2, Procedure:="AutoClear", _
Schedule:=False
End Function

Workbook_BeforeClose：

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call AutoDeactivate
End Sub

刚才发生的事太愚蠢了。我在取消工作中的事件时遇到了问题，所以我把Excel表带回家，对上面找到的补丁进行了编码。但是，它还是没有起作用。不是因为里面有错误，而是因为我家里没有Outlook！

没有Outlook应用程序会阻止事件在运行一次后重新安排时间(导致自动排除ActiveX错误消息)。

因此，一旦我把这个脚本恢复工作(安装了Outlook的地方)，一切就都正常了:)

标记这是我自己解决的哈哈。