'Is there a way to check if a PowerPoint is being presented using VBA code?
I am working on a VBA Module for an interactive PowerPoint. Specifically, I would like a text box to display the current time and update every second (like a live clock) using VBA. I have created and implemented the clock just fine except the clock does not exit its loop when the presentation ends and will continue to update the text box while editing the PowerPoint outside of the presentation mode. I have tried using the sub App_SlideShowEnd(ByVal Pres As Presentation)
( https://docs.microsoft.com/en-us/office/vba/api/powerpoint.application.slideshowend), sub App_SlideShowNextSlide(ByVal Wn As SlideShowWindow)
(https://docs.microsoft.com/en-us/office/vba/api/powerpoint.application.slideshownextslide), and even an add-in called AutoEvents (usage shown here http://www.mvps.org/skp/autoevents.htm#Use) to catch the end of the slide show, but to no avail.
So my question to you is: Is there a way to check if the current PowerPoint is actively presenting? If so, I could use it to check if the PowerPoint is presenting instead of checking my boolean variable clockstate
that allows the clock to count or not. Here is the implementation of just the clock sub:
Sub clock()
Do Until clockstate = False
MsgBox ActivePresentation.SlideShowWindow.View
Injury.TextFrame.TextRange.text = (Date - entryA) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Defect.TextFrame.TextRange.text = (Date - entryB) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Call Wait(1)
Loop
End Sub
Sub Wait(sec As Integer)
Dim temp_time As Variant
temp_time = Timer
Do While Timer < temp_time + sec
DoEvents 'this allows for events to continue while waiting for sec seconds
Loop
End Sub
Here is the implementation of just the App_SlideShowEnd
event:
Sub App_SlideShowEnd(ByVal Pres As Presentation)
clockstate = False
End Sub
And here is all of my code all together if you want to see it in one piece:
Option Explicit
Dim indexA As Integer 'this variable contains the slide that Injury_Time is found on for use in the auto next slide event
Dim indexB As Integer 'this varaible contains the slide that Defect_Time is found on for use in the auto next slide event
Dim clockstate As Boolean 'this varaible dictates wether or not the clock is on and counting to save memory/processing resources.
Dim Injury As Shape 'this variable is used to reference the textbox that gets changed by the macro
Dim Defect As Shape 'this varaible is used to reference the other textbox that gets changed by the macro
Dim entryA As Date 'this holds the contents of the first entrybox on the config form so the form can be unloaded without losing the entries
Dim entryB As Date 'this holds the contents of the second entrybox on the config form so the form can be unloaded without losing the entries
Dim daysA As String 'this holds the number of days since last injury for auto-setting the textboxes in the config form
Dim daysB As String 'this holds the number of days since last defect for auto-setting the textboxes in the config form
Sub Auto_Open() 'runs on startup from AutoEvents add-in. runs the find function to locate the Macro-edited slides, then opens the config form
'declare clockstate as false until it is true and turned on
clockstate = False
'assign values the global Injury and Defect variables
Call Find
'try calling the name fields (need to assign it to a variable to try it). If Injury and Defect were found, then nothing happens. Otherwise it moves the the Not_Found label
On Error GoTo Not_Found
'setup daysA and daysB
daysA = Left(Injury.TextFrame.TextRange.text, Len(Injury.TextFrame.TextRange.text) - 8)
daysB = Left(Defect.TextFrame.TextRange.text, Len(Defect.TextFrame.TextRange.text) - 8)
'assign default values to the Config boxes
Config.TextBox1.Value = Date - daysA
Config.TextBox2.Value = Date - daysB
'show config
Config.Show
Exit Sub
'error messaging for if the textbox assignments were not found
Not_Found:
MsgBox "Error: The Macro-edited textbox(es) were not found! This is likely due to the most recent editing preformed on this Powerpoint. Please revert the changes, create a new textbox with the name """"Injury_Time"""" or """"Defect_time"""" (whichever is missing), contact your local VBA expert, or read the Documentation for help."
End Sub
Sub Find() 'locates the textbox that the global variables Injury and Defect are supposed to represent
'use a 2D for loop to iterate through each slide and it's shapes
Dim i As Integer
Dim j As Integer
For i = 1 To ActivePresentation.Slides.Count
For j = 1 To ActivePresentation.Slides(i).Shapes.Count
If StrComp(ActivePresentation.Slides(i).Shapes(j).Name, "Injury_Time") = 0 Then
Set Injury = ActivePresentation.Slides(i).Shapes(j)
indexA = i
End If
If StrComp(ActivePresentation.Slides(i).Shapes(j).Name, "Defect_Time") = 0 Then
Set Defect = ActivePresentation.Slides(i).Shapes(j)
indexB = i
End If
Next j
Next i
End Sub
Sub Save() 'saves the contents of the config form to the global varaibles entryA and entry B then unloads the form to save memory
'save the contents of the config form so we can unload it to save memory
entryA = Config.TextBox1.Value
entryB = Config.TextBox2.Value
'unload the form to save memory
Unload Config
End Sub
Sub Auto_ShowBegin() 'starts the clock for the timers when the show starts
'start clock
clockstate = True
Call clock
End Sub
Sub clock()
Do Until clockstate = False
MsgBox ActivePresentation.SlideShowWindow.View
Injury.TextFrame.TextRange.text = (Date - entryA) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Defect.TextFrame.TextRange.text = (Date - entryB) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Call Wait(1)
Loop
End Sub
Sub Wait(sec As Integer)
Dim temp_time As Variant
temp_time = Timer
Do While Timer < temp_time + sec
DoEvents 'this allows for events to continue while waiting for sec seconds
Loop
End Sub
Sub App_SlideShowEnd(ByVal Pres As Presentation)
clockstate = False
End Sub
Sub Auto_Close() 'this is run by the AutoEvents add-in. It displays an informative message when the powerpoint is closed with instructions for the next time the powerpoint is opened
'prevent clock from running after program is closed
clockstate = False
'message to configure the powerpoint when it is opened again
MsgBox "Thank you for using this Macro-Enabled PowerPoint!" & vbCrLf & vbCrLf & "Next time the PowerPoint is opened, you will be asked to re-enter the dates of the most recent injury and quality defect."
End Sub
Thank you for your help and May the 4th be with you!
Solution 1:[1]
I think your 'Wait' function is not reliable. The 'for' loop may not end in some case. To control the clock ticking event, you can make use of Windows 'Timer' API. Though the Timer API is not that reliable or easy to use, it can be controlled and tailored.
The sample code goes like this:
Option Explicit
#If VBA7 Then
Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Public TimerID As LongPtr
#Else
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public TimerID As Long
#End If
Const Default As Integer = 1 'the target slide where the 'Clock' textbox exists
Dim Pause As Boolean
Sub StartNow()
StartTimer
End Sub
Sub StopNow()
StopTimer
End Sub
'main timer process : this sub-routine CANNOT be interrupted by any error or itself
Sub myTimer()
On Error Resume Next
If Pause Then Exit Sub
'the Default slide should have a textbox called 'Clock'
ActivePresentation.Slides(Default). _
Shapes("Clock").TextFrame.TextRange.Text = Format(Time, "hh:mm:ss")
End Sub
Function StartTimer()
If TimerID = 0& Then
TimerID = SetTimer(0&, 0&, 1000&, AddressOf myTimer) ' 1000 = 1sec
End If
End Function
Function StopTimer()
On Error Resume Next
KillTimer 0&, TimerID
TimerID = 0&
End Function
'the timer can be paused, if this macro is added to the 'Clock' textbox as an action trigger
Sub PauseTimer()
Pause = Not Pause
End Sub
'the timer must be stopped after finishing the show
Public Sub OnSlideShowTerminate(SSW As SlideShowWindow)
StopTimer
End Sub
'To start the clock automactically
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
If SSW.View.CurrentShowPosition = Default Then
StartTimer
Else
StopTimer
End If
End Sub
Requirement: A Textbox called 'Clock' should exist on Slide #1.
Warning:
- The Timer must be stopped after closing the show. Otherwise, Powerpoint application might crash!
- 'myTimer' should not contain any error or call itself recursively.
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
Solution | Source |
---|---|
Solution 1 | konahn |