VBA创建的计划任务休眠时失效，求通过VBA设置系统兼容版本的方法

问题概述 #

使用VBA创建Windows计划任务，用于定时启动Excel并执行宏，任务为一次性执行，宏执行后保持工作簿打开。环境为Windows 11 + Office 365：

• 电脑未休眠时任务正常运行，休眠时任务虽触发但Excel未打开
• 已设置WakeToRun = True，尝试过登录类型3（Interactive Token）和1（Password），其中类型1即使未休眠也会超时
• 手动将任务兼容系统版本从Windows Server 2008改为Windows 10后，休眠时任务可正常运行，但不知如何通过VBA配置该属性

解决方案 #

1. 设置任务兼容版本 #

Windows计划任务的Compatibility属性控制任务的系统兼容级别，对应枚举值：

• Windows Server 2008: 2
• Windows 10/11: 5

在VBA配置TaskSettings对象时添加一行代码，即可设置兼容版本为Windows 10（Windows 11可沿用此值）：

settings.Compatibility = 5

2. 登录类型优化 #

• 登录类型3（Interactive Token）：适合需要交互的场景，Win11下需确保任务配置为"不管用户是否登录都要运行"并勾选"使用最高权限运行"（当前VBA代码注册任务时已用参数6，对应TASK_CREATE_OR_UPDATE，登录类型为3）
• 登录类型1（Password）：需输入用户密码，且可能因权限限制或无交互会话导致超时，不推荐用于Excel宏执行场景

3. VBS脚本增强（可选） #

在生成的VBS脚本中添加错误处理，避免因异常导致Excel进程残留：

On Error Resume Next
' 原有代码...
If Err.Number <> 0 Then
    ExcelApp.Quit
    Set ExcelApp = Nothing
    WScript.Quit Err.Number
End If
On Error GoTo 0

修改后的完整代码 #

Sub CreateVBSFile()
    ' 仅需执行一次
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
    Dim fileStream As TextStream
    Set fileStream = fso.CreateTextFile(Environ("TEMP") & "\MyTestRun.vbs")
    Dim sS As String
    
    sS = "ExcelFilePath = """ & ThisWorkbook.FullName & """"
    fileStream.WriteLine sS
    sS = "MacroPath = ""Module1.testHarness"""
    fileStream.WriteLine sS
    
    ' 添加错误处理
    sS = "On Error Resume Next"
    fileStream.WriteLine sS
    
    sS = "Set ExcelApp = CreateObject(""Excel.Application"")"
    fileStream.WriteLine sS
    sS = "ExcelApp.Visible = True"
    fileStream.WriteLine sS
    sS = "ExcelApp.DisplayAlerts = False"
    fileStream.WriteLine sS
    
    sS = "Set wb = ExcelApp.Workbooks.Open(ExcelFilePath)"
    fileStream.WriteLine sS
    sS = "ExcelApp.Run MacroPath"
    fileStream.WriteLine sS
    
    sS = "wb.Save"
    fileStream.WriteLine sS
    sS = "ExcelApp.DisplayAlerts = True"
    fileStream.WriteLine sS
    
    ' 异常处理退出
    sS = "If Err.Number <> 0 Then"
    fileStream.WriteLine sS
    sS = "    ExcelApp.Quit"
    fileStream.WriteLine sS
    sS = "    Set ExcelApp = Nothing"
    fileStream.WriteLine sS
    sS = "    WScript.Quit Err.Number"
    fileStream.WriteLine sS
    sS = "End If"
    fileStream.WriteLine sS
    sS = "On Error GoTo 0"
    fileStream.WriteLine sS
    
    fileStream.Close
    Set fileStream = Nothing
    Set fso = Nothing
End Sub

Sub createTheSchedule()
    Cells(3, 3) = ""
    ' 设置启动时间为当前时间10分钟后
    Range("StartTm") = Format(DateAdd("s", 600, Now), "hh:mm ampm")
    Range("StartDt") = Format(Date, "mm/dd/yyyy")
    
    Const TriggerTypeTime = 1
    Const ActionTypeExec = 0
    Dim service As Object
    Set service = CreateObject("Schedule.service")
    service.Connect
    
    ' 获取任务根文件夹
    Dim rootFolder
    Set rootFolder = service.GetFolder("\")
    Dim taskDefinition
    Set taskDefinition = service.NewTask(0)
    
    ' 配置注册信息
    Dim regInfo
    Set regInfo = taskDefinition.RegistrationInfo
    regInfo.Author = "Administrator"
    
    ' 配置任务设置
    Dim settings
    Set settings = taskDefinition.settings
    settings.Enabled = True
    settings.WakeToRun = True
    settings.StartWhenAvailable = True
    settings.Hidden = False
    settings.idlesettings.RestartOnIdle = True
    settings.idlesettings.StopOnIdleEnd = False
    ' 设置兼容版本为Windows 10/11
    settings.Compatibility = 5
    
    ' 创建时间触发器
    Dim triggers, trigger
    Set triggers = taskDefinition.triggers
    Set trigger = triggers.Create(TriggerTypeTime)
    Dim startTime, time
    time = CDate(Range("StartDt")) + CDate(Range("StartTm"))
    startTime = XmlTime(time)
    trigger.StartBoundary = startTime
    trigger.ExecutionTimeLimit = "PT5M"    ' 执行超时时间5分钟
    trigger.ID = "timeTriggerID"
    trigger.Enabled = True
    
    ' 添加执行动作：运行VBS脚本
    Dim Action
    Set Action = taskDefinition.Actions.Create(ActionTypeExec)
    Action.Path = Environ("TEMP") & "\MyTestRun.vbs"
    
    ' 注册任务：TASK_CREATE_OR_UPDATE(6)，登录类型为Interactive Token(3)
    rootFolder.RegisterTaskDefinition "Book1", taskDefinition, 6, , , 3
End Sub

Function XmlTime(t)
    Dim cSecond, cMinute, CHour, cDay, cMonth, cYear
    Dim tTime, tDate

    cSecond = "00"
    cMinute = "0" & Minute(t)
    CHour = "0" & Hour(t)
    cDay = "0" & Day(t)
    cMonth = "0" & Month(t)
    cYear = Year(t)

    tTime = Right(CHour, 2) & ":" & Right(cMinute, 2) & ":" & Right(cSecond, 2)
    tDate = cYear & "-" & Right(cMonth, 2) & "-" & Right(cDay, 2)
    XmlTime = tDate & "T" & tTime
End Function

Sub testHarness()
    Cells(3, 3) = "This ran successfully at " & Format(Now(), "hh:mm:ss ampm")
End Sub

内容的提问来源于stack exchange，提问作者igittr