OnSlideShowPageChange触发后PowerPoint幻灯片无法跳转且切页宏失效

问题原因 #

• 现有代码使用无限Do...Loop循环占用了PPT的运行线程，完全阻塞了幻灯片切换、事件触发等默认操作
• 循环内仅读取进入页面时的幻灯片序号i，哪怕手动切页，循环里还是在尝试操作上一页的形状，既不会更新新页面的时钟，也会触发潜在报错

修复方案 #

核心思路是把阻塞线程的无限循环，替换为VBA自带的Application.OnTime定时调度方法，既不会阻塞主线程正常响应幻灯片操作，还能在切换页面时自动更新计时对象。

第一步：声明模块级变量 #

在代码编辑器的模块头部添加如下变量，用于存储定时任务的执行时间：

' 存下次定时执行的时间，用于取消定时任务
Dim nextRunTime As Date

第二步：替换原有事件代码 #

Sub OnSlideShowPageChange()
    Dim currentSlideIndex As Integer
    ' 先取消上一页的未执行定时任务，避免冲突
    On Error Resume Next
    Application.OnTime nextRunTime, "UpdateClock", , False
    On Error GoTo 0
    
    ' 获取当前页序号
    currentSlideIndex = ActivePresentation.SlideShowWindow.View.CurrentShowPosition
    
    ' 调用时钟更新方法，同时启动定时调度
    Call UpdateClock(currentSlideIndex)
End Sub

' 单独封装的时钟更新方法
Sub UpdateClock(Optional slideIdx As Integer = 0)
    Dim targetSlide As Slide
    ' 如果没有传入页码，默认取当前放映的页码
    If slideIdx = 0 Then slideIdx = ActivePresentation.SlideShowWindow.View.CurrentShowPosition
    
    On Error Resume Next ' 避免对应页面没有Rectangle 3时报错
    Set targetSlide = ActivePresentation.Slides(slideIdx)
    targetSlide.Shapes("Rectangle 3").TextFrame.TextRange.Text = Format(Now(), "hh:mm:ss")
    On Error GoTo 0
    
    ' 安排1秒后再次执行更新
    nextRunTime = Now() + TimeValue("00:00:01")
    Application.OnTime nextRunTime, "UpdateClock"
End Sub

第三步：添加放映结束清理逻辑 #

避免退出放映后后台残留定时任务报错：

Sub OnSlideShowTerminate()
    ' 退出放映时取消剩余的定时任务
    On Error Resume Next
    Application.OnTime nextRunTime, "UpdateClock", , False
    On Error GoTo 0
End Sub

注意事项 #

• 上述OnSlideShowPageChange和OnSlideShowTerminate事件代码需要放在「ThisPresentation」对象中，UpdateClock方法和模块级变量nextRunTime放在标准模块中即可，全部放在ThisPresentation也可正常运行
• 确保每一页幻灯片上都有名为Rectangle 3的矩形形状用于展示时间，否则对应页面不会更新时钟
• 如需保留自动跳转幻灯片的设置，直接在PPT的「切换」选项卡中设置每页的停留时长即可，不会再被代码阻塞
• 如果需要在原有时间基础上加偏移分钟，可以在Format之前对Now()做DateAdd处理即可

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