Timer on user form in Excel VBA

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开发者_Python百科 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

---

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.

I used the Windows Timer API for more accurate and smooth countdown (and also customizable down to ~100 millisecond timer resolution, depending on your processor. There's even a "tick tock" sound. ⏰

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 btnStartTimer_Click and btnStopTimer_Click.

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 ShowModal to 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.)}

---

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

---

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