Asynchronicity and Scheduling

What can you learn here ?
  • Timers
  • Scheduling tasks
  • Progress bars

Dealing with asynchronous events

VBA has Event Processing capabilities. This is how it is able to deal with mouse clicks, form events and so on. However this section is not about handling these kind of events that are triggered by 'something happening', but rather 'time passing'. These concepts are implemented as progress bar and countdown timer class in this project. You can download the finished project and include it in your own projects if you need a ready built, asynchronous timer. 

Application.Ontime

The Excel Application provides the OnTime method as a way to schedule future events. It is rather straightforward but also picky.

Here is a small program that will stop every 5 seconds to see if you want to do more. Note it will run forever.

Option Explicit
Dim pNextUpdate As Date
Const pUpdateInterval = 5
Sub testTimer()
    scheduleAnother
    While True
        DoEvents
    Wend
End Sub
Sub scheduleAnother()
    pNextUpdate = Now + TimeSerial(0, 0, pUpdateInterval)
    Application.OnTime pNextUpdate, "popup"
End Sub
Sub popup()
    If MsgBox("again?", vbYesNo) = vbYes Then scheduleAnother
End Sub

Application.Ontime's first 2 arguments are - the time it should run, followed by the name of the procedure to run (which needs to be in the scope of the procedure initiating the .Ontime method.

DoEvents

Our main procedure does nothing but loop endlessly. In this kind of heavy compute intensive environment, Excel does not service events, so it means that the event we scheduled never gets a chance to get focus. The DoEvents command tells Excel to go have a look to see if there are any events that need to be handled. 

Stopping when done

Let's modify our example a little so that it stops running when instructed to do so. The pNextUpdate variable will be 0 if instructed to stop. Otherwise it will be the time the next msgBox is due to be displayed. Note also it's scope - it has to have visibility across the whole module since it will be accessed in multiple procedures.

Option Explicit
Dim pNextUpdate As Date
Const pUpdateInterval = 5
Sub testTimer()
    scheduleAnother
    While pNextUpdate > 0
        DoEvents
    Wend
    MsgBox ("all done")
End Sub
Sub scheduleAnother()
    pNextUpdate = Now + TimeSerial(0, 0, pUpdateInterval)
    Application.OnTime pNextUpdate, "popup"
End Sub
Sub popup()
    pNextUpdate = 0
    If MsgBox("again?", vbYesNo) = vbYes Then scheduleAnother
End Sub

Making a countdown timer

There is a comprehensive countdown time class you can use implemented as part of this project. However you can see from this that we have the means to now create a report on some activity every 'x' seconds, which is essentially all that a countdown timer is. 

Here is a very simple implementation using the cProgressBar class, that will create a couple of shapes on the current worksheet and countdown graphically every second for 15 seconds, using them till it runs out of time, and looks like this. 


To implement this on a form instead, you can replace the shape with a label control on your form. You will need the cProgressBar class and the cGeneralObject class which are in the Gettingstartedseries workbook. If you are planning to use the createShapes procedure used in this example, you will also need the deviceAPI module - again, in the gettingStartedSeries workbook.


Option Explicit
Dim shpInner As Shape
Dim shpOuter As Shape
Dim ptimer As cProgressTimer
Sub shapeCountdownExecute()
    Set ptimer = New cProgressTimer
    createShapes
    With ptimer
        .init shpInner, "shapeUpdate", "shapeCountDownOutOfTime", 15
        .Start
    End With
    MsgBox ("all set up")
End Sub

Sub shapepTimerDestroy()
    TimerDestroy ptimer
End Sub

Public Sub shapeUpdate()
' this is an indirect call to a method because application.ontime cannot access within a class
    If Not ptimer Is Nothing Then
        ptimer.Update
    End If
End Sub

Public Sub shapeCountDownOutOfTime()
    outofTime ptimer
End Sub
Public Sub outofTime(pt As cProgressTimer)

    If Not pt Is Nothing Then
        With pt
            ' you must include this to mark that you have been called and have executed
            .calloutExecuted
            ' take some action for being out of time.. give it a bit longer and restart it
            If MsgBox("You have run out of time.. wait some more?", vbYesNo) = vbYes Then
                .ratioElapsed = 0.9
                .reStart
            Else
               TimerDestroy pt

            End If
        End With
    End If
End Sub

Sub TimerDestroy(pt As cProgressTimer)
    If Not pt Is Nothing Then
        pt.Destroy
        Set pt = Nothing
    End If
End Sub
Sub createShapes()
    Dim shp As Shape, i As Long

    ' create a couple of shapes
    With ActiveSheet
    ' delete any existing
        For i = .Shapes.Count To 1 Step -1
            .Shapes(i).Delete
        Next i
        Set shpOuter = .Shapes.AddShape(msoShapeRectangle, 10, 20, 100, 20)
    End With
    With shpOuter
        .Line.Weight = 4
        Set shpInner = ActiveSheet.Shapes.AddShape(.Type, _
                .left + .Line.Weight * PixelstoPoints.left, _
                .top + .Line.Weight * PixelstoPoints.top, _
                .Width - .Line.Weight * PixelstoPoints.left * 2, _
                .Height - .Line.Weight * PixelstoPoints.top * 2)
    End With
    With shpInner
        'change to some random color
        .Fill.ForeColor.SchemeColor = Int(Rnd() * 56)
        .Line.Weight = 0
        
    End With

End Sub

Create a progress Bar

The only real difference between a countdown timer and a progress bar is that one counts down (showing time left), and the other counts up (showing progress against predicted time). Implementing a progress bar is very similar to the countdown timer above.

In fact the only change required is to tell the .init method you want a progress bar instead of a countdown timer -- the 'true' in the call below

Sub shapeProgressBarExecute()
    Set ptimer = New cProgressTimer
    createShapes
    With ptimer
        .init shpInner, "shapeUpdate", "shapeCountDownOutOfTime", , True
        .Start
    End With
    MsgBox ("all set up")
End Sub

However, since a progress bar is supposed to be measuring and predicting progress, we'd better actually do some work and measure it.

Here is a typical Progress bar Implementation. In this case, I also used a parameter in .Init to indicate that I wanted to show %age completed on the bar.  The bar will look like this.

Sub shapeProgressBarExecute()
    Dim i As Long
    Const cLoop = 1000000
    Set ptimer = New cProgressTimer
    createShapes
    With ptimer
        .init shpInner, "shapeUpdate", "shapeCountDownOutOfTime", , True, , , , , True
        .Start
    End With
    '
    ' do something lots of times
    For i = 1 To cLoop
        doSomethingComplicated
        ' if this happens then the form has been closed down in the middle of processing
        If ptimer Is Nothing Then Exit Sub
        ' update how much of the task is completed and bar will adjust itself on next update
        ptimer.ratioElapsed = CDbl(i) / cLoop
    Next i
    ' wrap up

    ptimer.Flush
    Application.Wait 1
    MsgBox "Completed task in " & Format(ptimer.timeElapsed, ".##") & " seconds"
    shapepTimerDestroy
End Sub

The only thing you have to do here, is to communicate how much of the task is completed at opportune processing points, though use of the .ratioElapsed property. The Progress bar is only actually replotted according to the interval you specify (1 sec default). You can see that in the example above, if done synchronously, the bar would have been replot 1 million times, instead of 30 times. Note that you don't need to worry about DoEvents. When you update the .ratioElapsed property, it will take care of it if necessary.

For more stuff see my book - Going Gas.  All formats are available now from O'Reilly,Amazon and all good bookshops. You can also read a preview on O'Reilly.




Comments