Why implement a countdown timer
Avoiding ‘Microsoft time’
What’s needed?
- A label that will change color and size as the countdown progresses, and a textbox showing how many seconds are left.
- The capability to schedule an update that resizes and recolors the label and updates the textbox.
- A couple of controls to pause and restart the timer.
I’ve chosen to implement a class called cSudProgressBar to take care of these requirements, and to add a few controls to our form. This gives us this result – you can see the progress bar at the bottom, and I change the amount of time allowed depending on the calculated difficulty of the Sudoku. As usual the complete code and project is available in the download section.
Code and explanation
- For timing, i’m using the cMicroTimer function which I implemented as part of the optimization package.
- For scheduling updates, i’m using Application.ontime – this schedules the next time that the progress bar needs updating. There are some quirks about application.ontime
Application.ontime is a method of the global application object. Its function is to schedule an upcoming event in a particular period of time. The application object is provided by Excel as an abbreviation which does not need to be prefixed by the global object to which Application belongs. The problem is that if multiple instances of Excel are running, it can become disconnected ans screw up. Luckily I found this Microsoft explanation that helped me to figure out to fix that problem. This led me to calling application.ontime with a prefix identifying the specific application object , which i have previously initialized in cSudPuzzle as follows. Set pxlApp = GetObject(, “Excel.Application”).
Sub ScheduleUpdate() ' in case there are any outstanding - we only need one CancelScheduledUpdate 'TimeSerial(hours, minutes, seconds) pNextUpdate = Now + TimeSerial(0, 0, cUpdateInterval) pPuzzle.xlApp.Application.OnTime pNextUpdate, pScheduledUpdateProcess End Sub
One of the arguments for application.ontime is the name of the procedure that should run when the schedule time arrives (in this case the contents of pScheduleUpdateProcess). The strangeness here is that you cannot implement the called procedure as part of a class. It has to be a ‘normal procedure’. Since I wanted to encapsulate all this in the cSudProgressBar class, we need a workaround. In this case, I initialize the class, passing to it the name of a ‘normal procedure’ that will know which class method to call. This name is stored in pScheduleUpdateProcess so it can be passed to application.Ontime. All that progressupdate does is to call the appropriate method. The key is to make sure it is a public procedure of a ‘normal module’
.progress.init cspUzzle, .uForm.lbProgressBar,cspUzzle.Grid.timetoSolve, _ .uForm.tbCountDown, "progressupdate", _ .uForm.cbTimerStart, .uForm.cbTimerPaus
Public Sub progressUpdate() ' this is an indirect call to a method because application.ontime cannot access within a class If Not cspUzzle Is Nothing Then cspUzzle.FormGrid.progress.update End If End Sub
- The progress bar itself is an msforms.Label, whose length is shortened according to the %age of time that has passed. It will also change color as time runs out.
Public Sub update() ' mark this one as executed pNextUpdate = 0 If pTimeAllowed > 0 And Not pPaused Then cBar.Width = 1 + (pLength - complete * pLength) pCountDown.Value = Int(pTimeAllowed - (elapsed + pCum)) If complete < 0.34 Then pBar.BackColor = vbGreen ElseIf complete < 0.67 Then pBar.BackColor = vbYellow Else pBar.BackColor = vbRed End If End If ' update form DoEvents ' schedule another ScheduleUpdate End Sub
The complete code is below, or can be downloaded as part of the Sudoku Project.
Option Explicit Private Declare Function getFrequency Lib "kernel32" _ Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long Private Declare Function getTickCount Lib "kernel32" _ Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long Private pStart As Double Private pTimeAllowed As Double Private pLength As Long Private pBar As MSForms.label Private pCountDown As MSForms.TextBox Private pScheduledUpdateProcess As String Private pNextUpdate As Date Private pCum As Double Private pbutStart As MSForms.CommandButton Private pbutPause As MSForms.CommandButton Private pPaused As Boolean Private pPuzzle As cSudPuzzle Const cUpdateInterval = 2 Private Property Get cBar() As Control Set cBar = pBar End Property Private Property Get cTb() As Control Set cTb = pCountDown End Property Private Property Get cStart() As Control Set cStart = pbutStart End Property Private Property Get cPause() As Control Set cPause = pbutPause End Property Public Sub init(csp As cSudPuzzle, p As MSForms.label, secs As Long, ptb As MSForms.TextBox, what As String, _ pcbStart As MSForms.CommandButton, pbPause As MSForms.CommandButton) Set pBar = p Set pPuzzle = csp pTimeAllowed = secs pLength = cBar.Width Set pCountDown = ptb ptb.Value = secs pScheduledUpdateProcess = what Set pbutStart = pcbStart Set pbutPause = pbPause End Sub Public Sub start() pStart = cMicroTimer cBar.Visible = True cTb.Visible = True pbutStart.Visible = True pbutPause.Visible = True pbutStart.Enabled = True pbutPause.Enabled = True pCountDown.BackColor = vbWhite pCum = 0 pPaused = False ScheduleUpdate End Sub Public Sub pause() pCum = elapsed + pCum pCountDown.BackColor = vbRed pPaused = True End Sub Public Sub reStart() pStart = microtimer pCountDown.BackColor = vbWhite pPaused = False update End Sub Public Sub CancelScheduledUpdate() 'dont worry if one wasnt scheduled If pNextUpdate <> 0 Then pPuzzle.xlApp.Application.OnTime pNextUpdate, pScheduledUpdateProcess, , False Debug.Print "__Cancelling for " & pNextUpdate pNextUpdate = 0 End If End Sub Sub ScheduleUpdate() ' in case there are any outstanding - we only need one CancelScheduledUpdate 'TimeSerial(hours, minutes, seconds) pNextUpdate = Now + TimeSerial(0, 0, cUpdateInterval) pPuzzle.xlApp.Application.OnTime pNextUpdate, pScheduledUpdateProcess End Sub Public Sub destroy() If Not pBar Is Nothing Then CancelScheduledUpdate pBar.Visible = False cBar.Width = pLength cTb.Visible = False cTb.Value = Empty pTimeAllowed = 0 pStart = 0 pbutStart.Visible = False pbutPause.Visible = False pbutStart.Enabled = False pbutPause.Enabled = False End If End Sub Private Property Get complete() As Double Dim x As Double x = (elapsed + pCum) / pTimeAllowed If x > 1 Then complete = 1 Else complete = x End If End Property Private Property Get elapsed() As Double elapsed = cMicroTimer() - pStart End Property Public Sub update() ' mark this one as executed pNextUpdate = 0 If pTimeAllowed > 0 And Not pPaused Then cBar.Width = 1 + (pLength - complete * pLength) pCountDown.Value = Int(pTimeAllowed - (elapsed + pCum)) If complete < 0.34 Then pBar.BackColor = vbGreen ElseIf complete < 0.67 Then pBar.BackColor = vbYellow Else pBar.BackColor = vbRed End If End If ' update form DoEvents ' schedule another ScheduleUpdate End Sub Private Function cMicroTimer() As Double ' Returns seconds. Dim cyTicks1 As Currency Static cyFrequency As Currency cMicroTimer = 0 ' Get frequency. If cyFrequency = 0 Then getFrequency cyFrequency ' Get ticks. getTickCount cyTicks1 ' Seconds If cyFrequency Then cMicroTimer = cyTicks1 / cyFrequency End Function