Powerpoint countdown and current time in slides VBA

Add text fields- this VBA searches through the objects in the first frame until it finds "" in the text some where, truncates everything from and to the right and replaces it with an active countdown timer or current time in the box.

Refreshes every 500ms with a prtsafe call so it doesn't bog down the CPU. Add a slide advance to start the next slide and begin automated slide advancement.

Attribute VB_Name = "Countdown" Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long Public Sub Wait(Seconds As Double) ''non cpu-intensive wait timer ''https://stackoverflow.com/questions/57268161/sleep-wait-timer-in-powerpoint-vba-thats-not-cpu-intensive Dim endtime As Double endtime = DateTime.Timer + Seconds Do WaitMessage DoEvents Loop While DateTime.Timer < endtime End Sub Sub Countdown_from_Start() Dim Time As Date Dim Count As Integer Dim strBaseText As String Dim objShp As Shape Dim pos As Integer Time = Now() Count = 600 Time = DateAdd("S", Count, Time) On Error Resume Next ''Sort thorugh the shapes to find a For Each objShp In ActivePresentation.Slides(1).Shapes pos = 0: pos = InStr(1, objShp.TextFrame.TextRange.Text, "", vbTextCompare) If pos > 0 Then Exit For Set objShp = Nothing Next objShp On Error GoTo 0 If objShp Is Nothing Then Exit Sub ''nothing found strBaseText = objShp.TextFrame.TextRange.Text strBaseText = Left(strBaseText, pos - 2) Do Until Time < Now() DoEvents objShp.TextFrame.TextRange.Text _ = strBaseText & vbCr & Format(Time - Now(), "mm:ss") Wait 0.5 Loop objShp.TextFrame.TextRange = strBaseText & chr(60) & "count" & chr(62) End Sub Sub CurrentTime() Dim Time As Date Dim Count As Integer Dim strBaseText As String Dim objShp As Shape Dim pos As Integer Time = Now() Count = 600 Time = DateAdd("S", Count, Time) On Error Resume Next ''Sort thorugh the shapes to find a For Each objShp In ActivePresentation.Slides(1).Shapes pos = 0: pos = InStr(1, objShp.TextFrame.TextRange.Text, chr(60) & "count" & chr(62), vbTextCompare) If pos > 0 Then Exit For Set objShp = Nothing Next objShp On Error GoTo 0 If objShp Is Nothing Then Exit Sub ''nothing found strBaseText = objShp.TextFrame.TextRange.Text strBaseText = Left(strBaseText, pos - 2) Do Until Time < Now() DoEvents objShp.TextFrame.TextRange.Text _ = strBaseText & vbCr & Format(Now(), "hh:mm:ss a/p") Wait 1 Loop objShp.TextFrame.TextRange = strBaseText & chr(60) & "count" & chr(62) End Sub