I have created a simple userform with a text label. I have put this code on activation of userform to run remaining time from target time. It is good once it runs, but it does not count down... Seconds do not flick down ... etc.
Code
Private Sub UserForm_activate()
targtime = DateValue("28 Jun 2018") + TimeValue("18:37:00")
remtime = targtime - Now
Me.Label1 = Int(remtime) & " Days " & Format(remtime - Int(remtime), "HH:MM:SS")
End Sub
What am I doing wrong?
Put it in an endless loop and it would start ticking every second:
Private Sub UserForm_Activate()
Dim remTime As Date
While True
remTime = DateValue("28 Jun 2018") + TimeValue("18:37:00") - Now
Me.Label1 = Int(remTime) & " Days " & Format(remTime - Int(remTime), "HH:MM:SS")
Me.Repaint
Application.Wait Now + #12:00:01 AM#
Wend
End Sub
Related
I'm trying to make a choose your own type of game in powerpoint. The game includes a point system that I did using a macro when the user is clicks an option. I also need a hyperlink to jump to the right slide in accordance to the option that was picked.
I tried creating 1 macro for every button, assigning where to slide to jump to, but this becomes solution way too messy since, by the end of the game, there would be hundreds of buttons = hundreds of macro.
Dim numCorrect As Integer
Dim numIncorrect As Integer
Dim userName As String
Dim printableSlideNum As Long 'ADDED
Sub GetStarted()
Initialize
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub Initialize()
numCorrect = 0
numIncorrect = 0
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub Right()
numCorrect = numCorrect + 10
End Sub
Sub Wrong()
numIncorrect = numIncorrect + 25
End Sub
Sub Feedback()
MsgBox "You spent " & numCorrect + numIncorrect & " minutes to solve the issue" & vbCr & _
"Out of the " & numCorrect + numIncorrect & ", you wasted " & numIncorrect & " minutes by choosing the wrong options"
End Sub
Sub JumpTo(lSlideIndex As Long)
SlideShowWindows(1).View.GotoSlide (lSlideIndex)
End Sub
Sub ONEA()
Right
JumpTo 6
End Sub
I had an idea of creating a macro that jumped to a slide number according to the name of the shape, but don't know whether it is possible or not.
Example: option B jumps to slide 60
the shape name would be 60
the vba will match the shape name and jumps to slide 60
Any help/ideas for this is appreciated!
Note: my VBA skills is essentially zero.
To name your shape see How to name an object within a PowerPoint slide?
Sub JumpToSlide(oShp As Shape)
lSlideIndex = CLng(oShp.Name)
SlideShowWindows(1).View.GotoSlide (lSlideIndex)
End Sub
To assign this macro to the shape you can right-click on the shape --> Hyperlink --> Run a Macro --> Select "JumpToSlide"
I have a pop up that comes up after a user has been inactive for x amount of time. I can get the message box to come up and close my database after 30 seconds, however I would like to use a vbcancel button to allow the user to reset the timer.
I've managed to either get the program to shut after 30 seconds OR get the vbcancel button to work, but not both in conjunction - so i tried a loop. However i don't think i'm doing it correctly?
Public Property Get oMsgBox() As Object
Set oMsgBox = CreateObject("WScript.Shell")
End Property
Private Function IdleTimeDetected(ExpiredMinutes)
'oMsgBox.PopUp "Testing...closing in ten seconds.", 10, "Force Closed", vbInformation
oMsgBox.PopUp "No user activity detected in the last " & ExpiredMinutes & " minute(s)! Your copy of the Master Database will be closed in thirty seconds.", 30, "Force Close", vbCancel + vbInformation
Static ExpiredTime
Dim t As Date, tStop As Date
t = Now
tStop = t + TimeValue("00:00:30") 'Adjust the TimeValue as needed "hh:mm:ss"
Do Until t = tStop
DoEvents
Dim LResponse As Integer
LResponse = oMsgBox.PopUp("No user activity detected in the last " & ExpiredMinutes & " minute(s)! Your copy of the Master Database will be closed in thirty seconds.", 30, "Force Close", vbOKCancel + vbInformation)
If LResponse = vbCancel Then
ExpiredTime = 0
t = Now
Loop
DoCmd.RunCommand acCmdExit
End Function
Currently I get a message saying
The expression ON Timer you entered as the event property setting
produces the following error
Loop without do.
Thanks 4dmonster,
I took your advise and spotted my issue, then discovered a few more - like multiple message boxes and the database being closed regardless of which button you clicked so the form needed to be reset to restart the clocks.
I think i have ironed out the kinks!
Private Function IdleTimeDetected(ExpiredMinutes)
'oMsgBox.PopUp "Testing...closing in ten seconds.", 10, "Force Closed", vbInformation
Const IDLEMINUTES = 1
Static ExpiredTime
Dim LResponse As Integer
LResponse = oMsgBox.PopUp("No user activity detected in the last " & ExpiredMinutes & " minute(s)! Your copy of the Master Database will be closed in thirty seconds.", 30, "Force Close", vbOKCancel + vbInformation)
Dim t As Date, tStop As Date
t = Now
tStop = t + TimeValue("00:00:29") 'Adjust the TimeValue as needed "hh:mm:ss"
Do Until t = tStop
DoEvents
If LResponse = vbOK Then
DoCmd.RunCommand acCmdExit
Else
If LResponse = vbCancel Then
ExpiredTime = 0
DoCmd.OpenForm "DetectIdleTime", acDesign, , , , acHidden
End If
End If
t = Now
Loop
ExpiredMinutes = (ExpiredTime / 1000) / 60
If ExpiredMinutes >= IDLEMINUTES Then
DoCmd.RunCommand acCmdExit
End If
End Function
I am trying to work out how to get my progress bar to show the progress of the subroutine below. Does anyone have any ideas how to get the ball rolling on this one?
Any help or advice is appreciated.
Private Sub CommandButton8_Click()
Dim StartTime As Double
Dim MinutesElapsed As String
'Remember time when macro starts
StartTime = Timer
'*****************************
'Direct Data
Sheet4.Activate
Call Test1
Call Test2
Call Test3
Call Test4
'Return to Welcome Page
Sheet8.Activate
'*****************************
'Determine how many seconds the code took to run
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
'Notify user in seconds
MsgBox "This code ran successfully in " & MinutesElapsed & " minutes",
vbInformation
End Sub
Here's what I use for a progress bar:
Application.StatusBar = "Processing... " & CInt(nRow / nLastRow * 100) & "% " & String(CInt(nRow / nLastRow * 100), ChrW(9609))
DoEvents ' optional
nRow is the increment number
nLastRow is the value for 100% complete
When the loop is complete, reset it like this:
Application.StatusBar = ""
The logic behind a progressbar is this:
have a userform with a Label (or image or button) with the image of your example photo. Put it in a frame. The width of the frame is initialised to zero and grows as your number grows by either calling a Public Sub inside the userform, of directly Userform1.Frame1.width=Percent*MaxWidth/100.
Sometime you would want to add a doevents, wich i use only every X cycles (if clng(percent) mod X = 0 then doevents , for example).
Step 1: design a progress dialog box. For the following example, it must have the name frmProgress and have two text labels lblMsg1 and lblMsg2
Step 2: insert the following code in the dialog's code module:
Sub ShowProgressBox()
Me.Show vbModeless
End Sub
Sub SetProgressMsg(msg1, msg2)
If (msg1 <> "") Then Me.lblMsg1 = msg1
If (msg2 <> "") Then Me.lblMsg2 = msg2
DoEvents
End Sub
Sub SetProgressTitle(title)
Me.Caption = title
DoEvents
End Sub
Sub EndProgressBox()
Unload Me
End Sub
You can call these functions from your code to show progress messages.
Step 3: in your code, at the beginning of the lengthy operation, call
frmProgress.ShowProgressBox
Step 4: during the lengthy operation, regularly call the set function to show the user information, for example in a loop:
frmProgress.SetProgressMsg "Searching in "+ myArray(i), "Working..."
Step 5: Once done, close the progress box:
frmProgress.EndProgressBox
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
First of all I should say that I have no relevant experience in VBA but I badly need to make a timer in excel. I have managed to create stop and start buttons of the timer. But I have 20 different timers with start and stop buttons. I want to create a button that will be automatically start all timers while letting me stop individually a single timer.
I have produced the following code to start and stop them. But when I stop one of the timers I get the following error:"Run-time error '1004': Method 'onTime' of object'_application failed.
The code for the two start and stop buttons is:
Sub startTimer27()
Application.OnTime Now + TimeValue("00:00:01"), "Increment_count27"
End Sub
Sub Increment_count27()
Range("B2").Value = Range("B2") + 1
Range("B11").Value = Range("B11") + 1
Range("B19").Value = Range("B19") + 1
Range("B25").Value = Range("B25") + 1
Range("B33").Value = Range("B33") + 1
startTimer27
End Sub
Sub stopTimer27()
Application.OnTime Now + TimeValue("00:00:01"), "Increment_count27", Schedule:=False
End Sub
Have you considered using global variables saving the current time value?
Sub startTimer27()
starttime = Now
'MsgBox("The timer is running.")
End Sub
Sub stopTimer27()
timetaken = Now - starttime
MsgBox ("The time elapsed is " & Hour(timetaken) & ":" & Minute(timetaken) & ":" & Second(timetaken))
End Sub
Of course with your example it would be more like:
Public starttime(1 To 20) As Date
Sub cvbstartTimer27()
For i = 1 To 20
starttime(i) = Now
Next
End Sub
If you need to specifically stop it, then you'd have to give it a Boolean value too, that would be true when the timer is running and false when it's stopped. The lack of this value doesn't mean your code is wrong nevertheless.