Building a Segmented Countdown Timer for PowerPoint

Why a single countdown isn’t enough Link to heading

PowerPoint’s built-in “Rehearse Timings” only tracks total elapsed time. That’s fine for rehearsing a talk end to end, but it’s useless mid-presentation: it tells you how long you’ve been talking, not whether the specific section you’re on right now is running over. A 45-minute deck with five agenda items needs five separate budgets, not one running clock the presenter has to do subtraction against in their head.

The fix I built, Presentation Pacer, is a small VBA macro pair that overlays a countdown clock in the top-right corner of the active slide during a slide show. It’s segment-aware: define which slide ranges belong to which agenda item and how many minutes each gets, and the clock resets to a fresh countdown every time the presenter crosses into a new segment.

Segment-based, not just decorative Link to heading

The clock is color-coded so a presenter can read it at a glance without breaking eye contact with the audience:

  • Green: on schedule
  • Orange: less than 30 seconds left in the current segment’s budget
  • Red with a + prefix: over budget, and by how much

Segments are defined as a simple array of (start slide, end slide, minutes) tuples:

ranges = Array( _
    Array(1, 5, 5), _
    Array(6, 10, 15), _
    Array(11, 999, 30) _
)

Slides 1 to 5 get a 5-minute budget; the moment the presenter advances to slide 6, the clock resets and starts counting down from 15:00 for that section. Moving back and forth within the same segment doesn’t reset anything, only crossing into a different range does. Going backwards into a previous segment resets it too, starting the full budget over rather than trying to reconstruct how much time was already spent there.

The macOS problem: no Application.OnTime Link to heading

PowerPoint’s VBA object model exposes Application.OnTime on Windows for scheduling a callback after a delay, which is the obvious way to build a ticking clock. It doesn’t exist on macOS. Rather than accept a clock that only updates when the slide changes, I used a polling loop instead: StartClock runs a Do While loop that checks the system Timer and calls UpdateClock once a second, yielding to the OS via DoEvents on every iteration so the slide show stays responsive to clicks and keystrokes while the loop is alive.

Do While TimerRunning
    If Application.SlideShowWindows.Count = 0 Then
        TimerRunning = False
        Exit Do
    End If
    If Timer - lastTick >= 1 Or Timer < lastTick Then
        UpdateClock
        lastTick = Timer
    End If
    DoEvents
Loop

The loop starts when App_SlideShowBegin fires and exits automatically once the slide show window closes. A second event handler, App_SlideShowNextSlide, calls UpdateClock directly on every slide transition, so the display also refreshes immediately on navigation rather than waiting for the next second-tick.

Why a class module is needed for events at all Link to heading

PowerPoint doesn’t expose a ThisPresentation code-behind module the way Excel and Word do, so there’s no natural place to hook slide show events like SlideShowBegin or SlideShowNextSlide. The workaround is a class module (ClsPresEvents.cls) with a Public WithEvents App As Application declaration, instantiated and wired to the running Application object through a one-time InitEvents macro:

Public WithEvents App As Application

Private Sub App_SlideShowBegin(ByVal Wn As SlideShowWindow)
    Call StartClock
End Sub

Private Sub App_SlideShowNextSlide(ByVal Wn As SlideShowWindow)
    Call UpdateClock
End Sub

Private Sub App_SlideShowEnd(ByVal Pres As Presentation)
    Call StopClockTimer
End Sub

InitEvents, in the main module, just points that class instance at the live Application object so the three handlers above start firing:

Sub InitEvents()
    Set MojaKlasa.App = Application
    MsgBox "Clock wired up. You can start the slide show (F5).", vbInformation
End Sub

Because Auto_Open doesn’t run in .pptm files (only in .ppam add-ins), InitEvents has to be triggered manually once per session, before the first F5.

Full source Link to heading

The project is also on GitHub at github.com/Kozja/presentation-pacer, but both files are short enough to copy directly from here if that’s more convenient.

PrezentacjaZegar.bas, the standard module (import as ModZegar):

Option Explicit

Public CurrentSegmentKey As String
Public SegmentStartTime As Date
Public TimerRunning As Boolean
Public MojaKlasa As New KlasaZdarzen

Sub InitEvents()
    Set MojaKlasa.App = Application
    MsgBox "Clock wired up. You can start the slide show (F5).", vbInformation
End Sub

' Each row = (start slide, end slide, this segment's duration in minutes)
Sub GetSegmentInfo(slideIdx As Integer, ByRef durationSec As Long, ByRef segKey As String)
    Dim ranges() As Variant
    ranges = Array( _
        Array(1, 5, 5), _
        Array(6, 10, 15), _
        Array(11, 999, 30) _
    )

    Dim i As Integer
    For i = LBound(ranges) To UBound(ranges)
        If slideIdx >= ranges(i)(0) And slideIdx <= ranges(i)(1) Then
            durationSec = ranges(i)(2) * 60
            segKey = ranges(i)(0) & "-" & ranges(i)(1)
            Exit Sub
        End If
    Next i

    durationSec = -1
    segKey = "NONE"
End Sub

Sub StartClock()
    CurrentSegmentKey = ""   ' forces a reset on the first call
    TimerRunning = True

    Dim lastTick As Single
    lastTick = Timer   ' seconds since midnight

    Do While TimerRunning
        ' stop the loop once the slide show has ended
        If Application.SlideShowWindows.Count = 0 Then
            TimerRunning = False
            Exit Do
        End If

        ' refresh roughly once a second
        If Timer - lastTick >= 1 Or Timer < lastTick Then
            UpdateClock
            lastTick = Timer
        End If

        DoEvents   ' yield to the OS so clicks and slide changes stay responsive
    Loop
End Sub

Sub StopClockTimer()
    TimerRunning = False
End Sub

Sub UpdateClock()
    If Not TimerRunning Then Exit Sub

    Dim sw As SlideShowWindow
    On Error Resume Next
    Set sw = Application.SlideShowWindows(1)
    On Error GoTo 0
    If sw Is Nothing Then Exit Sub

    Dim curSlide As Integer
    curSlide = sw.View.Slide.SlideIndex

    Dim durationSec As Long
    Dim segKey As String
    GetSegmentInfo curSlide, durationSec, segKey

    If segKey <> CurrentSegmentKey Then
        CurrentSegmentKey = segKey
        SegmentStartTime = Now
    End If

    Dim elapsedInSeg As Long
    elapsedInSeg = DateDiff("s", SegmentStartTime, Now)

    Dim txt As String
    Dim isLate As Boolean
    isLate = False

    If durationSec = -1 Then
        Dim m As Integer, s As Integer
        m = elapsedInSeg \ 60
        s = elapsedInSeg Mod 60
        txt = Format(m, "00") & ":" & Format(s, "00")
    Else
        Dim remainSec As Long
        remainSec = durationSec - elapsedInSeg
        If remainSec < 0 Then
            isLate = True
            remainSec = -remainSec
        End If
        Dim mm As Integer, ss As Integer
        mm = remainSec \ 60
        ss = remainSec Mod 60
        If isLate Then
            txt = "+" & Format(mm, "00") & ":" & Format(ss, "00")
        Else
            txt = Format(mm, "00") & ":" & Format(ss, "00")
        End If
    End If

    Dim shp As Shape
    On Error Resume Next
    Set shp = sw.View.Slide.Shapes("ClockBox")
    On Error GoTo 0

    If shp Is Nothing Then
        Set shp = sw.View.Slide.Shapes.AddTextbox( _
            Orientation:=msoTextOrientationHorizontal, _
            Left:=sw.View.Slide.Master.Width - 140, _
            Top:=10, _
            Width:=125, _
            Height:=40)
        shp.Name = "ClockBox"
        With shp.TextFrame.TextRange
            .Font.Size = 28
            .Font.Bold = True
            .Font.Name = "Consolas"
            .ParagraphFormat.Alignment = ppAlignRight
        End With
        shp.Fill.Visible = msoFalse
        shp.Line.Visible = msoFalse
    End If

    shp.TextFrame.TextRange.Text = txt

    If isLate Then
        shp.TextFrame.TextRange.Font.Color.RGB = RGB(220, 30, 30)
    ElseIf durationSec <> -1 And (durationSec - elapsedInSeg) <= 30 Then
        shp.TextFrame.TextRange.Font.Color.RGB = RGB(230, 160, 0)
    Else
        shp.TextFrame.TextRange.Font.Color.RGB = RGB(0, 140, 60)
    End If

    ' No Application.OnTime on Mac; the clock refreshes on the next slide change instead.
End Sub

ClsPresEvents.cls, the class module (import as KlasaZdarzen):


Option Explicit

Public WithEvents App As Application

Private Sub App_SlideShowBegin(ByVal Wn As SlideShowWindow)
    Call StartClock
End Sub

Private Sub App_SlideShowNextSlide(ByVal Wn As SlideShowWindow)
    Call UpdateClock
End Sub

Private Sub App_SlideShowEnd(ByVal Pres As Presentation)
    Call StopClockTimer
End Sub

To use it: import both files through the VBA editor (Developer tab > Visual Basic > File > Import File), edit the ranges array in GetSegmentInfo for your own agenda, save the presentation as .pptm, then run InitEvents once per session before pressing F5.