Here's what I've put in my module:
Public Times As Boolean
Sub start()
Times = True
Track:
Application.OnTime Now() + TimeValue("00:00:01"), "Run"
If Times = True Then GoTo Track
End Sub
Sub run()
Range("E3").Value = Range("E3").Value + TimeValue("00:00:01")
End Sub
Sub Tend()
Times = False
End Sub
Now, when I run Start(), My Excel crashes.
Kindly Advice
Your code in Start is a tight loop which is not what you want to do I think.
Public Times As Boolean
Sub start()
Times = True
Run
End Sub
Sub run()
If Not Times Then Exit Sub
Application.OnTime Now() + TimeValue("00:00:01"), "Run"
Range("E3").Value = Range("E3").Value + TimeValue("00:00:01")
End Sub
Sub Tend()
Times = False
End Sub
Related
I am having difficult interrupting a looped Application.OnTime command. I have a macro I want to periodically loop every 5 seconds (CommandButton221), but then I want to be able to cut the loop off by pressing StopButton.
Private Sub CommandButton221_Click()
If StopMacro = True Then Exit Sub
'[Code that I want looping, not relevant to the question]
testup1
End Sub
Public Sub testup1()
RunWhen = Now + TimeValue("00:00:05")
Application.OnTime RunWhen, "CommandButton221_Click", , True
End Sub
Public Sub StopButton_Click()
StopMacro = True
End Sub
Any suggestions as how to achieve this would be hugely appreciated!
This should do it, a slightly different method, removing the schedule entirely when hitting the Stop button:
Public RunWhen As Double
Private Sub CommandButton221_Click()
Application.StatusBar = Now()
testup1
End Sub
Public Sub testup1()
RunWhen = Now + TimeValue("00:00:05")
Application.OnTime RunWhen, "CommandButton221_Click", , True
End Sub
Public Sub StopButton_Click()
On Error Resume Next
Application.OnTime EarliestTime:=RunWhen, Procedure:="CommandButton221_Click", Schedule:=False
End Sub
Make sure the code you have in 221 doesn't take more than 5 seconds to run!
Try using the command DoEvents at the end of testup1() to yield control back to the O.S., which should allow the stop button event to occur. It is very easy for VBA to get stuck in loops with timers and/or heavy data processing and ignore other events.
I am trying to create a macro that can automatically close the workbook within 5 minutes plus there will be a pop up reminder message at 4 mins 30 sec. I want the message box to be automatically closed in 10 seconds if user does not click the ok button. I am stuck at the point that the message box cannot close within 10 seconds. Most of my code are copied from the internet. Below are my codes:
In the workbook page:
Private Sub workbook_open()
Call settimer
End Sub
Private Sub workbook_beforeclose(cancel As Boolean)
Call stoptimer
End Sub
Private Sub workbook_sheetcalculate(ByVal sh As Object)
Call stoptimer
Call settimer
End Sub
Private Sub workbook_sheetselectionchange(ByVal sh As Object, _
ByVal target As Excel.Range)
Call stoptimer
Call settimer
End Sub
In the module
Dim downtime As Date
Sub settimer()
downtime = Now + TimeValue("00:01:00")
alerttime = downtime - TimeValue("00:00:50")
Application.OnTime Earliesttime:=alerttime, _
procedure:="alertuser", schedule:=True
Application.OnTime Earliesttime:=Downtime, _
procedure:="shutdown", schedule:=True
End Sub
Sub stoptimer()
On Error Resume Next
Application.OnTime Earliesttime:=downtime, _
procedure:="shutdown", schedule:=False
End Sub
Sub shutdown()
Application.DisplayAlerts = True
With ThisWorkbook
.Save = True
.Close
End With
End Sub
Sub alertuser()
Dim wsshell
Dim intText As Integer
Set wsshell = CreateObject("WScript.Shell")
intText = wsshell.Popup("log sheet will be closed in 30 seconds if there are no more inputs", 10, "reminder")
Set wsshell = Nothing
End Sub
You need to fully qualify your procedure name. It is not finding the procedure in question. You also had a typo and where missing the global variable alerttime. Try this:
Public downtime As Date
Public alerttime As Date
Private Sub workbook_open()
Call settimer
End Sub
Private Sub workbook_beforeclose(cancel As Boolean)
Call stoptimer
End Sub
Private Sub workbook_sheetcalculate(ByVal sh As Object)
Call stoptimer
Call settimer
End Sub
Private Sub workbook_sheetselectionchange(ByVal sh As Object, _
ByVal target As Excel.Range)
Call stoptimer
Call settimer
End Sub
Sub settimer()
downtime = Now + TimeValue("00:01:00")
alerttime = downtime - TimeValue("00:00:50")
'fully qualify your procedure name here and the procedure will run
Application.OnTime Earliesttime:=alerttime, _
procedure:="WorkbookName.xlsm!ThisWorkbook.alertuser", schedule:=True
'and here... also typo was here in downtime
Application.OnTime Earliesttime:=downtime, _
procedure:="WorkbookName.xlsm!ThisWorkbook.shutdown", schedule:=True
End Sub
Sub stoptimer()
On Error Resume Next
Application.OnTime Earliesttime:=downtime, _
procedure:="shutdown", schedule:=False
End Sub
Sub shutdown()
Application.DisplayAlerts = True
With ThisWorkbook
.Save = True
.Close
End With
End Sub
Sub alertuser()
Dim wsshell
Dim intText As Integer
Set wsshell = CreateObject("WScript.Shell")
intText = wsshell.Popup("log sheet will be closed in 30 seconds if there are no more inputs", 10, "reminder")
Set wsshell = Nothing
End Sub
You could use a userform (which you Insert into your project in the VBA editor) which looks something like this:
In the properties window I changed the forms name to formReminder to make it easier to refer to in other modules. Then, in the userform's code window I put:
Private Running As Boolean
Private Sub CommandButton1_Click()
Running = False
End Sub
Private Sub UserForm_Activate()
Dim start As Single
start = Timer
Running = True
Do While Running And Timer < start + 10
DoEvents
Loop
Unload Me
End Sub
Private Sub UserForm_Click()
Running = False
End Sub
When you run the line formReminder.Show anywhere else in the code (e.g. -- in place of where you create the popup) the form will display and show for 10 seconds (or less if you click anywhere on it) and then disappear.
While it displays it will look like this:
Thanks, John Coleman for your answer. It led me to a solution I've wanted for a long time. I took your code and converted it into a generic function that accepts parameters for the message and the number of seconds to wait.
Sub MsgBoxTimerTest()
' Test the Message box with a timer form
Dim vReturn As Variant
vReturn = MsgBoxTimerCall("MessageBox that Dissappears after n Seconds", "Hello World!", 3)
End Sub
' **************************************************************************
Function MsgBoxTimerCall(strCaption As String, strMessage As String, intSeconds As Integer)
' Show a messagebox for a while
' https://stackoverflow.com/questions/37281840/automatic-close-excel-workbook-with-a-pop-up-message
' 2016-06-21
TimerSeconds = intSeconds
msgBoxTimerForm.Caption = strCaption
msgBoxTimerForm.TextBox1.Value = strMessage
msgBoxTimerForm.Show
End Function
' **************************************************************************
' **************************************************************************
Insert this code in the form
' **************************************************************************
Private Running As Boolean
Private Sub CommandButton1_Click()
MsgBox "Yo!"
Running = False
End Sub
Private Sub UserForm_Activate()
Dim start As Single
start = Timer
Running = True
Do While Running And Timer < start + TimerSeconds
DoEvents
Loop
Unload Me
End Sub
Private Sub UserForm_Click()
Running = False
End Sub
I need to have my macro executed every 10 minutes .
This allows it to work in 10 minutes
sub my_Procedure ()
msgbox "hello world"
end sub
sub test()
Application.OnTime Now + TimeValue("00:00:10"), "my_Procedure"
end sub
But this works only once . How can I have my macro execute every 10 minutes ?
You should use this pattern:
Sub my_Procedure()
MsgBox "hello world"
Call test ' for starting timer again
End Sub
Sub test()
Application.OnTime Now + TimeValue("00:10:00"), "my_Procedure"
End Sub
Consider:
Public RunWhen As Double
Public Const cRunWhat = "my_Procedure"
Sub StartTimer()
RunWhen = Now + TimeSerial(0, 10, 0)
Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, _
schedule:=True
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime earliesttime:=RunWhen, _
procedure:=cRunWhat, schedule:=False
End Sub
Sub my_Procedure()
MsgBox "hello world"
Call StartTimer
End Sub
all in a standard module..............be sure to run StopTimer before exiting Excel
NOTE
The "minute" argument in TimeSerial is the second argument.
I'm writing a big macro for MS Word 2013 and one of the parts of it should be sub that prevents user from writing text; user should be able to use hotkey (eg. ctrl+q) to stop (or start) this sub (I already know how to assign a hotkey to a sub). I'm pretty new to VBA. I've googled for the answer but there's only instruction how to write such macro for Excel, but it doesn't work in Word. Is there a way to do this? How?
Thank you in advance.
Dim startTime As Single
Dim stopTime As Single
Dim timeToRun
Dim totalTime
Dim tmpTime
Dim avg As Long
Public isStart As Boolean
Public Sub hotkeyPressed() 'I wrote module to handle this'
If isStart = True Then
stopButton_Click
Else
startButton_Click
End If
End Sub
Private Sub startButton_Click()
totalTime = tmpTime
startTime = Timer
isStart = True
startButton.Enabled = False
stopButton.Enabled = True
ActiveDocument.Protect _
Type:=wdNoProtection
End Sub
Private Sub stopButton_Click()
isStart = False
stopTime = Timer
tmpTime = totalTime + tmpTime
startButton.Enabled = True
stopButton.Enabled = False
ActiveDocument.Protect _
Type:=wdAllowOnlyReading
End Sub
Private Sub Document_New()
startButton.Caption = "Start!"
stopButton.Caption = "Stop"
isStart = False
Call scheduler
ActiveDocument.Protect _
Type:=wdAllowOnlyReading
On Error GoTo Handler:
Open "KM\" + ActiveDocument.Name + ".txt" For Input As #1
Input #1, line
tmpTime = line
Close #1
Exit Sub
Handler:
tmpTime = 0
End Sub
Private Sub Document_Close()
MyFile1 = "KM\" + ActiveDocument.Name + ".txt"
fnum = FreeFile()
Open MyFile1 For Output As fnum
Print #fnum, totalTime
Close fnum
End Sub
Private Sub scheduler()
timeToRun = Now + TimeValue("00:00:01")
Application.OnTime timeToRun, "getNumberOfLetters"
End Sub
Sub getNumberOfLetters()
If isStart = True Then
numOfLetters = ActiveDocument.Characters.Count
totalTime = Timer - startTime
timeLabel.Caption = totalTime + tmpTime
charLabel.Caption = numOfLetters
setResult
End If
Call scheduler
End Sub
Private Sub setResult()
avg = 60 * numOfLetters / czasLabel.Caption
avg.Caption = avg
End Sub
Have you tried simply using the .Protect method?
Sub ProtectDocument()
ActiveDocument.Protect _
Type:=wdAllowOnlyReading
End Sub
This will prevent user input. You can unprotect the document using VBA if necessary:
Sub UnprotectDocument()
ActiveDocument.Protect _
Type:=wdNoProtection
End Sub
I have a macro called UpdateMacro which updates my Database from my Excel
I want to create a macro called RepeatMacro where it executes the UpdateMacro every 2 seconds automatically and only Start and Stop Buttons are to be provided to start and Stop execution of the RepeatMacro.
How can it be done?
Google for Application.OnTime
E.g.
Dim dtNextRunTime As Date
dtNextRunTime = Now + TimeSerial(0,0,2)
Application.OnTime dtNextRunTime, "MyProcedure", True
To clear a previously set procedure, you need to save the time at which it was scheduled )e.g. dtNextRunTime above), then use:
Application.OnTime dtNextRunTime, "MyProcedure", False
Here's a sample VB module with methods StartSchedule / StopSchedule to get you going:
Private m_dtScheduledTime As Date
Private m_lDelaySeconds As Long
Private m_bIsScheduled As Boolean
Private Sub DoWork()
m_bIsScheduled = False
' ... do your work
' Reschedule at the same frequency once completed
StartSchedule m_lDelaySeconds, "DoWork"
End Sub
Public Sub StartSchedule(ByVal DelaySeconds As Long)
StopSchedule
m_lDelaySeconds = DelaySeconds
m_dtScheduledTime = Now + TimeSerial(0, 0, m_lDelaySeconds)
Application.OnTime m_dtScheduledTime, "DoWork", True
m_bIsScheduled = True
End Sub
Public Sub StopSchedule()
If m_bIsScheduled Then
Application.OnTime m_dtScheduledTime, "DoWork", False
m_bIsScheduled = False
End If
End Sub
This will run UpdateMacro every two seconds, assuming UpdateMacro takes less than two seconds to run.
Sub RepeatMacro()
Dim lastRunTime
Do
lastRunTime = Now
Range("A1") = "Last run: " & Format(lastRunTime, "hh:nn:ss")
Call UpdateMacro
DoEvents
Application.Wait lastRunTime + TimeValue("00:00:02")
Loop
End Sub
Sub UpdateMacro()
Debug.Print "running UpdateMacro"
End Sub
EDIT To start and stop RepeatMacro from your sheet, make a start button and a stop button, and put the following code in your Sheet module. Also notice that I added a DoEvents in RepeatMacro above.
Private Sub StartButton_Click()
Call RepeatMacro
End Sub
Private Sub StopButton_Click()
MsgBox "Stopped."
End
End Sub
Now just saying End is poor practice, but you get the idea.