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.
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
Comments
Post a Comment