I've got some old Excel VBA code where I want to run a task at regular intervals. If I were using VB6, I would have used a timer control.
I found the Application.OnTime() method, and it works well for code that's running in an Excel worksheet, but I can't make it work in a user form. The method never gets called.
How can I make Application.OnTime() call a method in a user form, or are there other ways to schedule code to run in VBA?
I found a workaround for this. If you write a method in a module that just calls a method in your user form, then you can schedule the module method using Application.OnTime().
Kind of a kludge, but it'll do unless somebody has a better suggestion.
Here's an example:
''//Here's the code that goes in the user form Dim nextTriggerTime As Date Private Sub UserForm_Initialize() ScheduleNextTrigger End Sub Private Sub UserForm_Terminate() Application.OnTime nextTriggerTime, "modUserformTimer.OnTimer", Schedule:=False End Sub Private Sub ScheduleNextTrigger() nextTriggerTime = Now + TimeValue("00:00:01") Application.OnTime nextTriggerTime, "modUserformTimer.OnTimer" End Sub Public Sub OnTimer() ''//... Trigger whatever task you want here ''//Then schedule it to run again ScheduleNextTrigger End Sub ''// Now the code in the modUserformTimer module Public Sub OnTimer() MyUserForm.OnTimer End Sub
How about moving all the code to a 'Timer' module.
Dim nextTriggerTime As Date Dim timerActive As Boolean Public Sub StartTimer() If timerActive = False Then timerActive = True Call ScheduleNextTrigger End If End Sub Public Sub StopTimer() If timerActive = True Then timerActive = False Application.OnTime nextTriggerTime, "Timer.OnTimer", Schedule:=False End If End Sub Private Sub ScheduleNextTrigger() If timerActive = True Then nextTriggerTime = Now + TimeValue("00:00:01") Application.OnTime nextTriggerTime, "Timer.OnTimer" End If End Sub Public Sub OnTimer() Call MainForm.OnTimer Call ScheduleNextTrigger End Sub
Now you can call from the mainform:
call Timer.StartTimer call Timer.StopTimer
To prevent errors, add:
Private Sub UserForm_Terminate() Call Timer.StopTimer End Sub
Wich will trigger:
Public Sub OnTimer() Debug.Print "Tick" End Sub
I needed a visible countdown timer that could stay on top of other windows and run smoothly whether making changes to the workbook, or minimizing the Excel window. So, I adapted the @don-kirkby's creative code above for my own purposes and figured I'd share the result.
The code below requires creation of a module and a userform as noted in the comments, or you can download the
.xlsm at the bottom of this answer.
Insert a new module and save it as
modUserFormTimer. Add two form control command buttons to the worksheet, labelled Start Timer and Stop Timer and assigned procedures
Option Explicit 'modUserFormTimer Public Const showTimerForm = True 'timer runs with/without the userform showing Public Const playTickSound = True 'tick tock (a WAV sounds could be embedded: `https:// goo.gl/ ReuUyd`) Public Const timerDuration = "00:00:20" 'could also Insert>Object a WAV for tick or alarm Public Const onTimerStart_MinimizeExcel = True 'minimize Excel? (countdown remains visible) Public Const onTimerStart_MaximizeExcel = True 'maximize Excel when timer completes? 'timer could be on top of other applications; instructions here: `https:// goo.gl/ AgmWrM` 'safe for 32 or 64 bit Office: Private Declare PtrSafe Function SetTimer Lib "User32" (ByVal hWnd As Long, ByVal nIDEvent As Long, _ ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long Private Declare PtrSafe Function KillTimer Lib "User32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long Public Declare PtrSafe Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long Public schedTime As Date 'this is the "major" timer set date Private m_TimerID As Long Public Sub OnTimerTask() 'the procedure that runs on completion of the "major timer" (timer won't reschedule) Unload frmTimer '''''''''''''''''''''''''''''' MsgBox "Do Something!" ' < < < < < Do Something Here '''''''''''''''''''''''''''''' End Sub Public Sub btnStartTimer_Click() schedTime = Now() + TimeValue(timerDuration) InitTimerForm End Sub Public Sub btnStopTimer_Click() 'clicking the 'x' on the userform also ends the timer (disable the close button to force continue) schedTime = 0 frmTimer.UserForm_Terminate End Sub Public Sub InitTimerForm() 'run this procedure to start the timer frmTimer.OnTimer Load frmTimer If showTimerForm Then If onTimerStart_MinimizeExcel Then Application.WindowState = xlMinimized frmTimer.Show 'timer will still work if userform is hidden (could add a "hide form" option) End If End Sub Public Sub StartTimer(ByVal Duration As Long) 'Begin Millisecond Timer using Windows API (called by UserForm) If m_TimerID = 0 Then If Duration > 0 Then m_TimerID = SetTimer(0, 0, Duration, AddressOf TimerEvent) If m_TimerID = 0 Then MsgBox "Timer initialization failed!", vbCritical, "Timer" End If Else MsgBox "The duration must be greater than zero.", vbCritical, "Timer" End If Else MsgBox "Timer already started.", vbInformation, "Timer" End If End Sub Public Sub StopTimer() If m_TimerID <> 0 Then 'check if timer is active KillTimer 0, m_TimerID 'it's active, so kill it m_TimerID = 0 End If End Sub Private Sub TimerEvent() 'the API calls this procedure frmTimer.OnTimer End Sub
Next, create a userform, save it as
frmTimer. Add a text box named
txtCountdown. Set property
False. Paste the following into the form's code window:
Option Explicit 'code for userform "frmTimer" 'requires a textbox named "txtCountdown" and "ShowModal" set to False. Dim nextTriggerTime As Date Private Sub UserForm_Initialize() ScheduleNextTrigger End Sub Public Sub UserForm_Terminate() StopTimer If schedTime > 0 Then schedTime = 0 End If If onTimerStart_MaximizeExcel Then Application.WindowState = xlMaximized 'maximize excel window Unload Me End Sub Private Sub ScheduleNextTrigger() 'sets the "minor" timer (for the countdown) StartTimer (1000) 'one second End Sub Public Sub OnTimer() 'either update the countdown, or fire the "major" timer task Dim secLeft As Long If Now >= schedTime Then OnTimerTask 'run "major" timer task Unload Me 'close userForm (won't schedule) Else secLeft = CLng((schedTime - Now) * 60 * 60 * 24) If secLeft < 60 Then 'under 1 minute (don't show mm:ss) txtCountdown = secLeft & " sec" Else 'update time remaining in textbox on userform If secLeft > 60 * 60 Then txtCountdown = Format(secLeft / 60 / 60 / 24, "hh:mm:ss") Else 'between 59 and 1 minutes remain: txtCountdown = Right(Format(secLeft / 60 / 60 / 24, "hh:mm:ss"), 5) End If End If If playTickSound Then Beep 16000, 65 'tick sound End If End Sub
Download the demo
.xksm. here. There are numerous ways this can be customized or adapted to specific needs. I'm going to use it to calculated and display real time statistics from a popular Q&A site in the corner of my screen...
Note that, since it contains VBA macro's, the file could may set off your virus scanner (as with any other non-local file with VBA). If you're concerned, don't download, and instead build it yourself with the information provided.)
Thanks to user1575005 !!
Used the code in a Module to setup a Timer() process:
Dim nextTriggerTime As Date Dim timerActive As Boolean Public Sub StartTimer() Debug.Print Time() & ": Start" If timerActive = False Then timerActive = True Call ScheduleNextTrigger End If End Sub Public Sub StopTimer() If timerActive = True Then timerActive = False Application.OnTime nextTriggerTime, "OnTimer", Schedule:=False End If Debug.Print Time() & ": End" End Sub Private Sub ScheduleNextTrigger() If timerActive = True Then nextTriggerTime = Now + TimeValue("00:00:10") Application.OnTime nextTriggerTime, "OnTimer" End If End Sub Public Sub OnTimer() Call bus_OnTimer Call ScheduleNextTrigger End Sub Public Sub bus_OnTimer() Debug.Print Time() & ": Tick" Call doWhateverUwant End Sub Private Sub doWhateverUwant() End Sub