PowerPoint播放时自动运行VBA函数实现数据更新的方法求助

一、绑定演示开始/结束的触发事件 #

要让更新逻辑在演示启动时自动运行，需在ThisPresentation模块中绑定演示生命周期事件：

' 粘贴到ThisPresentation模块
Private Sub Presentation_SlideShowBegin(ByVal Wn As SlideShowWindow)
    StartAutoUpdate ' 启动定时更新任务
End Sub

Private Sub Presentation_SlideShowEnd(ByVal Wn As SlideShowWindow)
    StopAutoUpdate ' 停止定时更新任务
End Sub

二、实现定时更新的两种可行方法 #

方法1：使用Windows API定时器（高精度） #

PowerPoint VBA无内置定时器，可调用Windows API实现精准定时：

' 粘贴到标准模块（如Module1）
#If VBA7 Then
    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
    Dim timerID As LongPtr
#Else
    Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Dim timerID As Long
#End If

Const UPDATE_INTERVAL As Long = 5000 ' 5秒，单位毫秒

Sub StartAutoUpdate()
    timerID = SetTimer(0, 0, UPDATE_INTERVAL, AddressOf TimerCallback)
End Sub

Sub StopAutoUpdate()
    If timerID <> 0 Then
        KillTimer 0, timerID
        timerID = 0
    End If
End Sub

' 定时器回调：调用你的Excel数据更新函数
Sub TimerCallback(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long)
    UpdatePPTFromExcel ' 替换为你已写好的更新函数
End Sub

注意：

• 64位Office需保留PtrSafe和LongPtr，32位则删除这些关键字，将LongPtr替换为Long。
• UpdatePPTFromExcel函数中，演示模式下修改文本框需用SlideShowWindows(1).View.Slide.Shapes("文本框名称").TextFrame.TextRange.Text，而非普通视图的Shape对象。

方法2：循环+DoEvents（简单易实现） #

若不想用API，可通过循环结合DoEvents实现定时更新，同时保证PPT播放不卡顿：

' 粘贴到标准模块（如Module1）
Dim isUpdating As Boolean
Const UPDATE_INTERVAL As Long = 5 ' 5秒

Sub StartAutoUpdate()
    isUpdating = True
    Do While isUpdating And Application.SlideShowWindows.Count > 0
        UpdatePPTFromExcel ' 调用你的更新函数
        WaitWithDoEvents UPDATE_INTERVAL ' 等待指定时间
    Loop
End Sub

Sub StopAutoUpdate()
    isUpdating = False
End Sub

' 带响应的等待函数，避免PPT假死
Sub WaitWithDoEvents(seconds As Long)
    Dim endTime As Double
    endTime = Now + TimeSerial(0, 0, seconds)
    Do While Now < endTime
        DoEvents ' 释放CPU控制权，维持PPT播放响应
    Loop
End Sub

注意：

• Application.SlideShowWindows.Count > 0用于判断演示是否仍在运行，防止演示结束后循环继续。
• 此方法精度略低于API定时器，但实现简单，适合多数场景。

额外注意事项 #

• 操作Excel时，优先用GetObject绑定已打开的实例，避免重复启动Excel：

  Dim xlApp As Object
  Set xlApp = GetObject(, "Excel.Application") ' 绑定现有Excel
  ' 或指定文件：Set xlApp = GetObject("C:\你的数据文件.xlsx")
  

• 务必在演示结束时调用StopAutoUpdate，防止VBA后台持续运行消耗资源。

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