I'm trying to create a countdown in Visual Basic for my PowerPoint presentation. This worked absolutely fine. I need the macro to start when The slide changes. The slide has to change after 20 seconds. This also works. But when I change the slide programmatically the method OnSlideShowChangedPage doesn't run. Does anyone have an idea why it doesn't work?
This is my code:
Sub OnSlideShowPageChange(ByVal Wn As SlideShowWindow)
MsgBox "Fired"
Dim pos As Integer
pos = Wn.View.CurrentShowPosition
Dim time As Date
time = Now()
Dim count As Integer
count = 20
time = DateAdd("s", count, time)
Do Until time < Now()
DoEvents
ActivePresentation.Slides(pos).Shapes("countdown").TextFrame.TextRange = Format((time - Now()), "hh:mm:ss")
Loop
ActivePresentation.SlideShowWindow.View.Next
End Sub
Related
I am trying to run a live clock on every slide in a PowerPoint presentation for a kiosk.
I am able to get the live time to run perfectly and in the preferred format on the first slide. The slide will not advance. The macro will not run on the second slide when advanced manually. Here is my code.
It seems that the code is overriding the default slideshow settings?
Sub OnSlideShowPageChange()
Dim i As Integer
Dim time As Date
time = Now()
time = DateAdd("n", minutes, time)
i = ActivePresentation.SlideShowWindow.View.CurrentShowPosition
Do
DoEvents
With ActivePresentation.Slides(i).Shapes("Rectangle 3").TextFrame.TextRange
.Text = Format(Now(), "hh:mm:ss")
End With
Loop
End Sub
I figured out that the slides wouldn't advance because I was stuck in the loop. Here is my fix...but its success is sporadic. Sometimes it will scroll through 5 slides and then get stuck on a slide, other times 2. I am not sure what is happening. Still digging at it.
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
Dim i As Integer
Dim time As Date
Dim tstop As Date
time = Now()
time = DateAdd("n", minutes, time)
tstop = time + TimeValue("00:00:10")
i = ActivePresentation.SlideShowWindow.View.CurrentShowPosition
Do Until time = tstop
DoEvents
With ActivePresentation.Slides(i).Shapes("Rectangle 3").TextFrame.TextRange
.Text = Format(Now(), "hh:mm:ss AM/PM")
End With
time = Now()
Loop
End Sub
I'm attempting to make a GUI for a school project in Excel of a basic security system. I'm trying to have the macro take the user to the alarm slide (slide 8) if the timer runs out and if the disarm boolean is false. However, as I have it now, no matter what the user is always taken to the alarm slide once the timer runs out. I'm not sure what the issue is exactly.
The ARM_DISARM is run by an action button on the disarmed slide.
Global Disarm As Boolean
Sub timelimit()
Disarm = False
ActivePresentation.SlideShowWindow.View.GotoSlide (3)
Dim time As Date
time = Now()
Dim count As Integer
count = 5
time = DateAdd("s", count, time)
Do Until time < Now()
DoEvents
For i = 3 To 6 'slide numbers'
ActivePresentation.Slides(i).Shapes("countdown").TextFrame.TextRange = Format((time - Now()), "hh:mm:ss")
Next i
Loop
If Disarm = False Then
ActivePresentation.SlideShowWindow.View.GotoSlide (8)
End If
End Sub
Sub ARM_DISARM()
Disarm = True
End Sub
I'm trying to mimic a screensaver on PowerPoint that will return to my first slide after X amount of seconds of inactivity.
The PowerPoint presentation is all just completely image based and every click will transition through the slides, so it doesn't have to be sophisticated at all, just that at the start of each slide it counts down 5 seconds, then returns to slide 1 (which is my fake screensaver page).
I've already got something working in a basic format, it takes you to the first page after 5 seconds, but the timer doesn't restart once you go to a new slide, once it starts counting down, regardless of if you move to the next slide after 3 seconds, you don't get another 5 second countdown, it just finishes the remaining 2 seconds and redirects you.
VBA is definitely not my primary language, I'm just piecing this together with what I can find, but my current code is below
Sub Auto_NextSlide(Index As Long)
Dim Delay, Start
If Index > 1 Then
Delay = 5
Start = Timer
Do While Timer < Start + Delay
DoEvents
Loop
SlideShowWindows(1).View.GotoSlide (SlideShowWindows(1).Presentation.Slides(1).SlideIndex)
End If
End Sub
Try maybe something like below (using class events)
' AppEvents class module
Option Explicit
Public WithEvents App As Application
Const Delay As Integer = 5
Dim Start
Dim actualSlide As Integer
Private Sub App_SlideShowNextSlide(ByVal Wn As SlideShowWindow)
With Wn.Presentation.SlideShowWindow
Start = Timer
actualSlide = .View.Slide.SlideIndex
If actualSlide > 1 Then
Do While Timer < Start + Delay
DoEvents
If .View.Slide.SlideIndex <> actualSlide Then
Start = Timer
actualSlide = .View.Slide.SlideIndex
End If
Loop
.View.GotoSlide (.Presentation.Slides(1).SlideIndex)
End If
End With
End Sub
Module code
' Module 1
Option Explicit
Public pApp As AppEvents
Sub GetAppClass()
Set pApp = New AppEvents
Set pApp.App = Application
ActivePresentation.SlideShowSettings.Run
End Sub
avid reader, first time poster here. I have a Macro that I obtained from the internet for the most part, then made some adjustments. It's purpose is to color code cells that have passed a certain duration. It was working fine earlier, but now I am getting an error on it for a "Type Mismatch". The line that reads "This is where the error is" is where I am getting the mismatch. I am puzzled because it was working fine earlier. I am not a seasoned programmer by any means, but I just try to troubleshoot things. I have looked all over the net and cant find a specific answer to my question.
In addition, if any of you are willing, I would appreciate your advice on how to make this code run ONLY at startup of the workbook and NOT periodically as it is set up to do so now.This code is not placed in a worksheet, but in a Module.I mention this because I am not sure how much of a practical difference it can make any help is appreciated, thanks!
Public TimeToRun As Date
Sub Auto_Open()
Call ScheduleCompareTime
End Sub
Sub ScheduleCompareTime()
TimeToRun = Now + TimeValue("00:00:10")
Application.OnTime TimeToRun, "CompareTimeStamp"
End Sub
Sub CompareTimeStamp()
Dim rgTimeStamp As Range
Dim rdTimeStamp As Range
Dim i As Long
Dim j As Long
Dim MyNow As Date
Dim TimeStamp As Date, TimeStampp As Date
Set rgTimeStamp = Range("c1:c500")
Set rdTimeStamp = Range("H1:h500")
For i = 1 To rgTimeStamp.Rows.Count
If Not rgTimeStamp.Cells(i, 1) < 1 Then 'don't run for an empty cell
MyNow = CDate(Now - TimeSerial(0, 0, 0)) 'time instantly
TimeStamp = CDate(rgTimeStamp.Cells(i, 1)) 'THIS IS WHERE THE ERROR IS!!
If TimeStamp < MyNow Then 'if it's old at all
rgTimeStamp.Cells(i, 1).Interior.ColorIndex = 3 'make fill colour red
End If
End If
Next
For j = 1 To rdTimeStamp.Rows.Count
If Not rdTimeStamp.Cells(j, 1) < 1 Then
MyNow = CDate(Now - TimeSerial(0, 0, 0))
TimeStampp = CDate(rdTimeStamp.Cells(j, 1))
If TimeStampp < MyNow Then
rdTimeStamp.Cells(j, 1).Interior.ColorIndex = 3
End If
End If 'closes If Not
Next
Call ScheduleCompareTime 'begins the scheduler again
End Sub
Sub auto_close() 'turn the scheduler off so you can close workbook
Application.OnTime TimeToRun, "CompareTimeStamp", , False
End Sub
You probably have data in one or more cells that Excel cannot convert to a date. You can get around this by adding some simple checking such as this:
'.... beginning of your code
If Not rgTimeStamp.Cells(i, 1) < 1 Then 'don't run for an empty cell
MyNow = CDate(Now - TimeSerial(0, 0, 0)) 'time instantly
If IsDate(rgTimeStamp.Cells(i, 1)) = False Then
MsgBox "Invalid date found in cell " & rgTimeStamp.Cells(i, 1).Address(False, False)
Exit Sub
End If
TimeStamp = CDate(rgTimeStamp.Cells(i, 1)) 'THIS IS WHERE THE ERROR IS!!
If TimeStamp < MyNow Then 'if it's old at all
rgTimeStamp.Cells(i, 1).Interior.ColorIndex = 3 'make fill colour red
End If
End If
'... rest of your code
If you only want the code to run at startup then change Sub Auto_Open to this:
Sub Auto_Open()
Call CompareTimeStamp
End Sub
I have the following code for executing a macro on opening a workbook, until the time to executing it comes (until a maximum time limit):
Private Sub Workbook_Open()
Dim time_executing_macro As Date
Dim maximum_time_to_launch_macro As Date
time_executing_macro = "17:00:00"
maximum_time_to_launch_macro = "19:00:00"
Do
If (Now() >= time_executing_macro) Then
MsgBox ("OK")
Exit Sub
End If
Loop Until (Now() >= maximum_time_to_launch_macro)
End Sub
The problem is that, as of today at 12:21, the code keeps launching the MsgBox. As far as I know 12:21:00 < 17:00:00, so what am I doing wrong?
Thanks in advance.