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
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 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
I'm trying to come up with a way to close an excel document after a period of inactivity. The problem i'm running into is that if excel is in Edit mode, the macro will not execute. This would be for a workbook that is on a server that multiple people have access to, the problem is that some people leave it open and forget that they have it open and no one else can edit it hence the need for this.
I've create a VBA macro code that only closes the excel document while the user is not in edit mode:
Sub OpenUp()
Dim Start, Finish, TotalTime, TotalTimeInMinutes, TimeInMinutes
Application.DisplayAlerts = True
TimeInMinutes = 1 ' sets timer for 1 minutes
If TimeInMinutes > 1 Then
TotalTimeInMinutes = (TimeInMinutes * 60) - (1 * 60)
' times 60 seconds to "minutize"/convert time from seconds to minutes
Start = Timer ' Sets the start time.
Do While Timer < Start + TotalTimeInMinutes
DoEvents ' Yield to other Excel processes.
Loop
Finish = Timer ' Set end time.
TotalTime = Finish - Start ' Calculate total time.
Application.DisplayAlerts = False
MsgBox "You've had this file open for " & TotalTime / 60 & " minutes. You have 1 minute to save all your files before Excel closes"
End If
Start = Timer ' Sets the start time.
Do While Timer < Start + (1 * 60)
DoEvents ' Yield to other Excel processes.
Loop
Finish = Timer ' Set end time.
TotalTime = Finish - Start ' Calculate total time.
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.Quit
End Sub
I know this request kind of defies logic as you don't want the workbook to close while someone is in the middle of a edit hence why you can't run a macro while in edit mode. But if there is any way to set up some code to save and close a workbook after a certain set time period has passed i would have need of it in this circumstance. Thanks
You need place the below code and save the file to XLSM type. Reopen the file to run the macro
Place the code in the standard module
Option Explicit
Public EndTime
Sub RunTime()
Application.OnTime _
EarliestTime:=EndTime, _
Procedure:="CloseWB", _
Schedule:=True
End Sub
Sub CloseWB()
Application.DisplayAlerts = False
With ThisWorkbook
.Save
.Close
End With
End Sub
Place the code in the Thisworkbook Module
Option Explicit
Private Sub Workbook_Open()
EndTime = Now + TimeValue("00:00:20") '~~> 20 Seconds
RunTime
End Sub
Place this in each worksheet to detect any changes in the worksheet
Private Sub Worksheet_Change(ByVal Target As Range)
If EndTime Then
Application.OnTime _
EarliestTime:=EndTime, _
Procedure:="CloseWB", _
Schedule:=False
EndTime = Empty
End If
EndTime = Now + TimeValue("00:00:20") '~~> 20 Seconds
RunTime
End Sub
I have got the answer from this site
http://www.excelforum.com/excel-programming-vba-macros/600241-excel-vba-close-workbook-after-inactivity.html
I am writing a code to copy data from one spreadsheet to an other one in every second. I have tried Application.Wait and Sleep but they blocked both spreadsheets so I decided to use a do until loop. It works but 1 sec lasts almost 2 sec and I don't know why. So I left only the loop in the code but the test gave the same result (it took ca 95 sec). Any suggestion? Here is the code:
Sub Test()
Dim Delay As Date
cell = 1
For i = 1 to 60
Workbooks("Data").Worksheets("Sheet1").Range("C" & cell).Value = cell
cell = cell +1
Delay = Now() + TimeValue("00:00:01")
Do Until Now() >= Delay
Do Events
Loop
Next i
End Sub
That is only an approximate delay because you really have no idea of what else is going through the message queue and being processed by the DoEvents command (one word btw). An alternative would be to call the procedure from within itself with the Application.OnTime method.
Sub timed_routine()
Application.Interactive = False
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1) = 1
Application.Interactive = True
'Debug.Print Timer
Application.OnTime Now + TimeSerial(0, 0, 1), "timed_routine"
End Sub
With the Debug.Print Timer command uncommented and active, this routine was cycling in about 1.015 seconds.
I have a small scrip that basically presses "F2" for me every 4 minutes for the duration of 8hours for the active application.
It works and is really basic as my skills in VB are extremely limited.
I now thought of a new addition to the project but have no idea if it is possible or how to tackle it.
I would basically like to have a small window in which the timer is displayed as well as a Pause and Resume and Stop button. It would be of a huge advantage if I could have these buttons as if I´m in another application, i don´t want the F2 button pressed.
Here is what I have:
Dim WshShell
Set WshShell = CreateObject("WScript.Shell")
dim ti
ti=timer
Do
WshShell.SendKeys "{F2}"
For AA = 1 To 9
IF AA = 8 Then BB = "in 30 seconds"
IF AA = 9 Then BB = "now !"
WScript.Sleep 30000
Dim oShell
Set oShell= CreateObject("Wscript.Shell")
IF AA = 8 OR AA = 9 Then oShell.Popup " Refresh ... " & BB & " ",2,"Remind"
Next
Loop while (timer-ti)<8*60*60
MsgBox "VB End: " & Time()
Thank you
OK, just a high level answer as it's late and I'm going to bed.
On your form, place a timer control. Set it for a 1000 interval (1 sec).
Place your start & pause buttons also.
Here's the code that will run it.
Dim IsRunning As Boolean
Private Sub cmdPause_Click()
IsRunning = False
End Sub
Private Sub cmdStart_Click()
IsRunning = True
End Sub
Private Sub Timer1_Timer()
Static LastTime As Date
If IsRunning Then
If DateDiff("n", lastdate, Now()) >= 4 Then
'sendkeys
LastTime = Now()
End If
End If
End Sub
The IsRunning variable is outside any procedure and is called a shared variable. Any procedure within this form can see it. The start & pause buttons turn the value of it to true or false.
The Timer event will run every sec. Here we're checking if IsRunning is true and also if 4 minutes has expired yet. If so, then you can run your sendkeys.