Asynchronous programming is tricky enough already, and VBA doesn't make life any easier. I wanted to create some basic functionality to allow async processes to mark completion without having to implement any complicated interfaces.
The basic idea was to raise a regular stream of events, or
Ticks, and then to check the value of a supplied variable each time. These are performed in the Tick method of a main class:
Option Explicit Implements ITicker 'to allow tick method to remain hidden Public Event Tick() Public Event Timeout() Public Event Complete() Private Const waitIndefinitely As Double = -1 Private Type tTimer tickFrequency As Double 'in seconds startTime As Double endTime As Double neverTimeout As Boolean conditionAddress As LongPtr End Type Private this As tTimer Public Sub Await(ByRef processComplete As Boolean, Optional ByVal tickFrequency As Double = 0.5, Optional ByVal maxWait As Double = 10) this.conditionAddress = VarPtr(processComplete) If maxWait = waitIndefinitely Then this.neverTimeout = True ElseIf maxWait >= 0 Then this.startTime = timer this.endTime = this.startTime + maxWait Else Err.Raise 5, , "Max wait must be positive or -1 (for no timeout)" End If startTicking tickFrequency, Me End Sub Private Sub ITicker_Tick() If Peek(this.conditionAddress, vbBoolean) Then 'check if val has changed stopTicking RaiseEvent Complete ElseIf timer > this.endTime Then stopTicking RaiseEvent Timeout Else RaiseEvent Tick End If End Sub Private Sub Class_Terminate() stopTicking End Sub
The class implements an interface in order to keep its methods secret.
Public Sub Tick() End Sub
A regular stream of events (well callbacks really) are what drives everything in its asynchronous glory. These are generated with a Windows API Timer to schedule regular function calls:
Option Explicit Private Declare Function SetTimer Lib "user32" ( _ ByVal HWnd As Long, ByVal nIDEvent As Long, _ ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Private Declare Function KillTimer Lib "user32" ( _ ByVal HWnd As Long, ByVal nIDEvent As Long) As Long Private Type tGenerator caller As ITicker timerID As Long End Type Private this As tGenerator Public Sub startTicking(ByVal tickFrequency As Double, ByVal caller As ITicker) Set this.caller = caller this.timerID = SetTimer(0, 0, tickFrequency * 1000, AddressOf Tick) End Sub Private Sub Tick(ByVal HWnd As Long, ByVal uMsg As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long) this.caller.Tick End Sub Public Sub stopTicking() On Error Resume Next KillTimer 0, this.timerID End Sub
The whole setup runs until a certain condition is met, or the class raches a timeout value. The idea was to pass the condition
ByRef which means if the caller code changed its value to
True (marking the async task complete), the timer code would be aware of it. However a bit of trickery is required to monitor a value passed to a class
ByRef, involving checking the memory at the address of the variable. A utility module holds the generic method (as described here)
Option Explicit Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _ Any, source As Any, ByVal bytes As Long) ' read a value of any type from memory Public Function Peek(ByVal address As Long, ByVal ValueType As VbVarType) As Variant Select Case ValueType Case vbByte Dim valueB As Byte CopyMemory valueB, ByVal address, 1 Peek = valueB Case vbInteger Dim valueI As Integer CopyMemory valueI, ByVal address, 2 Peek = valueI Case vbBoolean Dim valueBool As Boolean CopyMemory valueBool, ByVal address, 2 Peek = valueBool Case vbLong Dim valueL As Long CopyMemory valueL, ByVal address, 4 Peek = valueL Case vbSingle Dim valueS As Single CopyMemory valueS, ByVal address, 4 Peek = valueS Case vbDouble Dim valueD As Double CopyMemory valueD, ByVal address, 8 Peek = valueD Case vbCurrency Dim valueC As Currency CopyMemory valueC, ByVal address, 8 Peek = valueC Case vbDate Dim valueDate As Date CopyMemory valueDate, ByVal address, 8 Peek = valueDate Case vbVariant ' in this case we don't need an intermediate variable CopyMemory Peek, ByVal address, 16 Case Else Err.Raise 1001, , "Unsupported data type" End Select End Function
What I'm after
I'd like a bit of feedback on a few areas in particular:
- Use of Api functions. They seem to be leading to a few crashes!
- Use of the
ITickerinterface. I've never used interfaces to hide methods before
- User interface; I've tried to keep it very simple with friendly VBA Events, but is this useful?
- Errors; how should I be raising them. This is a very simple application so I haven't done anything fancy
One example of using this is in monitoring user interaction such as worksheet selection changes
Option Explicit Private WithEvents testclass As asyncTimer Private countReached As Boolean Sub runtests() Set testclass = New asyncTimer countReached = False Range("A1") = 1 Range("B1") = 1 testclass.Await countReached, 0.5, 5 End Sub Private Sub testclass_Complete() MsgBox "done" End Sub Private Sub testclass_Tick() Range("B1") = Range("B1") + 1 End Sub Private Sub testclass_Timeout() MsgBox "timeout" End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Range("A1") = Range("A1") + 1 countReached = Range("A1") > 10 Range("A2") = countReached End Sub
Here the value of
A1 shows the number of selection change events,
A2 whether the condition (as seen by the timer) is True or False, and
B1 shows the number of elapsed Ticks.