用VBA在PPT中制作假屏幕保护程序

Question

我正试图在PowerPoint上模仿一个屏幕保护程序，它将在X秒不活动后返回到我的第一张幻灯片。

PowerPoint演示文稿完全是基于图像的，每次点击都会在幻灯片之间切换，所以它根本不需要复杂，只需在每张幻灯片开始时倒计时5秒，然后返回到幻灯片1(这是我的假屏幕保护页面)。

我已经有了一些在基本格式下工作的东西，它会在5秒后带你到第一页，但是一旦你转到新的幻灯片，计时器就不会重新启动，一旦开始倒计时，无论你在3秒后转到下一张幻灯片，你都不会再倒计时5秒，它只会完成剩下的2秒并重定向你。

VBA绝对不是我的主要语言，我只是把它和我能找到的东西拼凑在一起，但我现在的代码如下

Sub Auto_NextSlide(Index As Long)

Dim Delay, Start

If Index > 1 Then
    Delay = 5
    Start = Timer
    Do While Timer < Start + Delay
        DoEvents
    Loop

    SlideShowWindows(1).View.GotoSlide (SlideShowWindows(1).Presentation.Slides(1).SlideIndex)
End If

End Sub

Answer 1

可以尝试下面这样的方法(使用类事件)

' AppEvents class module
Option Explicit

Public WithEvents App As Application

Const Delay As Integer = 5

Dim Start
Dim actualSlide As Integer


Private Sub App_SlideShowNextSlide(ByVal Wn As SlideShowWindow)
    With Wn.Presentation.SlideShowWindow
        Start = Timer
        actualSlide = .View.Slide.SlideIndex
        If actualSlide > 1 Then
            Do While Timer < Start + Delay
                DoEvents
                If .View.Slide.SlideIndex <> actualSlide Then
                    Start = Timer
                    actualSlide = .View.Slide.SlideIndex
                End If
            Loop
            .View.GotoSlide (.Presentation.Slides(1).SlideIndex)
        End If
    End With
End Sub

模块代码

' Module 1
Option Explicit

Public pApp As AppEvents

Sub GetAppClass()
    Set pApp = New AppEvents
    Set pApp.App = Application
    ActivePresentation.SlideShowSettings.Run
End Sub