VBA Countdown Timer

Question

I created a countdown timer in VBA from some code I found a while back. The issue is that if I duplicate the timer to use on a different slide, they are both linked and will both start at the same time. This means that when I pause the timer on one slide, it becomes the starting point of the next.

I'm wanting to know what the simplest way is of duplicating my timer where each one is independent of the others. I'm looking to have around 10 timers on 10 different slides.

I've tried copying and pasting the timer, then changing the shape names in the selection panel which the code pulls on as the action buttons. This didn't work the way I thought it would. I thought about just changing the macros names and then linking it to the new timer. But I couldn't find any macros attached to any of the timer's buttons.

Here is a file with the timer: Timer Powerpoint (Note: Only 1 timer will work on one slide at a time, so place any duplicate on a different slide. Open in ppt not google slides.)

Any help with this would be amazing.

CODE:

` 
Option Explicit
Global timeLeft As Date
Global updateTimer As Boolean
Global timerRunning As Boolean
Global changeTimerbyValue
Global currentTimerSlide As Integer
Global pauseTimer As Boolean
Sub countdownTimer()
On Error Resume Next

Dim thisSlide As Slide
Dim currentSlide As Integer
currentSlide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
For Each thisSlide In ActivePresentation.Slides
    thisSlide.Shapes("PauseTimer").Visible = True
    thisSlide.Shapes("StartTimer").Visible = False
    thisSlide.Shapes("EndBackground").Visible = False
    thisSlide.Shapes("MainBackground").Visible = True
Next thisSlide

updateTimer = False
timerRunning = True

Dim seconds As Integer
seconds = ActivePresentation.Slides(currentSlide).Shapes("seconds").TextFrame.TextRange
Dim minutes As Integer
minutes = ActivePresentation.Slides(currentSlide).Shapes("minutes").TextFrame.TextRange
Dim hours As Integer
hours = ActivePresentation.Slides(currentSlide).Shapes("hours").TextFrame.TextRange
Dim time As Date
time = hours & ":" & minutes & ":" & seconds

Dim currentTime As Date
currentTime = Now()

Dim timerTime As Date

timerTime = DateAdd("s", seconds + 60 * minutes + 3600 * hours + 0.99, currentTime)
pauseTimer = False

Do Until timerTime < Now()
    DoEvents
    If (updateTimer = True) Then
        timerTime = DateAdd("s", changeTimerbyValue, timerTime)
        updateTimer = False
    End If
    
    timeLeft = timerTime - Now()
    
 For Each thisSlide In ActivePresentation.Slides
    thisSlide.Shapes("hours").TextFrame.TextRange = Format(timeLeft, "hh")
    thisSlide.Shapes("minutes").TextFrame.TextRange = Format(timeLeft, "nn")
    thisSlide.Shapes("seconds").TextFrame.TextRange = Format(timeLeft, "ss")
 Next thisSlide
 
    If (pauseTimer) Then
        pauseTimer = False
        timerRunning = False
        Exit Do
    End If
Loop
    timerRunning = False

For Each thisSlide In ActivePresentation.Slides
    thisSlide.Shapes("PauseTimer").Visible = False
    thisSlide.Shapes("StartTimer").Visible = True
Next thisSlide

    ActivePresentation.Slides(currentSlide).Shapes("EndBackground").Visible = False
    ActivePresentation.Slides(currentSlide).Shapes("MainBackground").Visible = True
    If (timerTime < Now()) Then
        For Each thisSlide In ActivePresentation.Slides
            thisSlide.Shapes("hours").TextFrame.TextRange = Format(0, "hh")
            thisSlide.Shapes("minutes").TextFrame.TextRange = Format(0, "nn")
            thisSlide.Shapes("seconds").TextFrame.TextRange = Format(0, "ss")
        Next thisSlide
        ActivePresentation.Slides(currentSlide).Shapes("EndBackground").Visible = True
        ActivePresentation.Slides(currentSlide).Shapes("MainBackground").Visible = False
        Beep
        Call AppWait
        Beep

        Call AppWait
        Beep
        Call AppWait
        ActivePresentation.Slides(currentSlide).Shapes("EndBackground").Visible = False
        ActivePresentation.Slides(currentSlide).Shapes("MainBackground").Visible = True
    End If
End Sub
Sub hitPause()
    pauseTimer = True
    Dim currentSlide As Integer
    currentSlide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
End Sub
Sub changeTime(ByVal theTime As Integer)
    On Error Resume Next
    Dim currentSlide As Integer
    Dim thisSlide As Slide
    currentSlide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
    If (currentTimerSlide <> currentSlide And currentTimerSlide <> 0 And timerRunning = True) Then
     pauseTimer = True
    Exit Sub
    End If
    
    Dim currentTime As Date
    currentTime = Now()
    
    Dim seconds As Integer
    seconds = ActivePresentation.Slides(currentSlide).Shapes("seconds").TextFrame.TextRange
    Dim minutes As Integer
    minutes = ActivePresentation.Slides(currentSlide).Shapes("minutes").TextFrame.TextRange
    Dim hours As Integer
    hours = ActivePresentation.Slides(currentSlide).Shapes("hours").TextFrame.TextRange
    
    If (timerRunning = True) Then
        If (theTime = -3600 And hours = 0) Then
            'Do nothing
        ElseIf (theTime = -60 And hours = 0 And minutes = 0) Then
            'Do nothing
        Else
            changeTimerbyValue = theTime
            updateTimer = True
        End If
        
    End If
    
    If (timerRunning = False) Then

        Dim time As Date
        time = hours & ":" & minutes & ":" & seconds
        Dim timerTime As Date
        If (theTime = -3600 And hours = 0) Then
            timerTime = DateAdd("s", seconds + 60 * minutes + 3600 * hours + 0.99, currentTime)
        ElseIf (theTime = -60 And hours = 0 And minutes = 0) Then
            timerTime = DateAdd("s", seconds + 60 * minutes + 3600 * hours + 0.99, currentTime)
        Else
            timerTime = DateAdd("s", seconds + 60 * minutes + 3600 * hours + 0.99, currentTime)
            timerTime = DateAdd("s", theTime, timerTime)
        End If
        
       timeLeft = timerTime - Now()
    For Each thisSlide In ActivePresentation.Slides
        thisSlide.Shapes("hours").TextFrame.TextRange = Format(timeLeft, "hh")
        thisSlide.Shapes("minutes").TextFrame.TextRange = Format(timeLeft, "nn")
        thisSlide.Shapes("seconds").TextFrame.TextRange = Format(timeLeft, "ss")
    Next thisSlide
    End If

End Sub
Sub increaseSeconds()
    changeTime (1)
End Sub
Sub decreaseSeconds()
    changeTime (-1)
End Sub
Sub increaseMinutes()
    changeTime (60)
End Sub
Sub decreaseMinutes()
    changeTime (-60)
End Sub
Sub increaseHours()
    changeTime (3600)
End Sub
Sub decreaseHours()
    changeTime (-3600)
End Sub
Sub startTimer()
    If (timerRunning = False) Then
        Call countdownTimer
    End If
End Sub
Sub AppWait()
  Dim WAIT As Double
  WAIT = Timer
  While Timer < WAIT + 0.75 ' 1 seconds
    DoEvents  'do nothing
  Wend
End Sub







`

Answer 1

You can duplicate timelimit and countdown objects on each slide you need. Just make sure those objects have exactly the same names. Then, you can get the active slide in a Loop. On activating another slide, the countdown object on that slide will be updating.

Something like this:

Sub countdown()
  Dim activeSlide As Slide
  Dim count As Integer
  Dim tstart As Date
  Dim tend As Date
  tstart = Now()
  Do While True
    DoEvents
    Set activeSlide = _
      PowerPoint.Application.ActiveWindow.View.Slide
    count = activeSlide.Shapes("timelimit").TextFrame.TextRange
    tend = DateAdd("n", count, tstart)
    activeSlide.Shapes("countdown").TextFrame.TextRange = _
      Format((tend - Now()), "nn:ss")
    If tend < Now() Then
      activeSlide.Shapes("countdown").TextFrame.TextRange = "TIME UP"
    End If
  Loop
End Sub