# A rather accurate VBA stopwatch

## Intro

I'm trying to come up with a neat, accurate way of timing VBA code, as I'm yet to find a method to do this in VBA directly (without plugins etc.)

The general idea was to create some Stopwatch class which could be initialised at the start of a test procedure, then various markers could be dotted throughout the code under review and when execution reaches these markers, the stopwatch class makes a note of the time.

To get an in-depth profile of code execution, I wanted to be able to differentiate between Main methods and Sub methods (ie if Sub Foo calls Sub A and Sub B, it would be nice to have stats for Foo, and beneath it, A and B individually). Another LabelTree class could be used to build up this hierarchy model.

Finally a StopwatchResults class can hold methods required to turn raw timestamp data (held in TimeInfo classes) into execution times for different methods, and return that info in required formats (currently just printing or as a LabelTree object).

Put that all together and you can write something like this:

Sub testRoutine()
Dim ck As New Stopwatch
ck.Start
ck.OpenLabel "HeavyWork"
DoSomeHeavyWork
ck.CloseLabel
ck.OpenLabel "LoopTest"
Dim i As Long
For i = 1 To 5
DoSomeHeavyWork 0.1
ck.Lap
Next i
ck.CloseLabel
ck.Finish
ck.Results.ToImmediateWindow
End Sub


Which prints for example:

Label name    Time taken
-----------------------------------
1 Start        1.00116134128621            1.90410726645496E-03
1.1 HeavyWork  0.500211852449866           2.6879100187216E-04
1.2 LoopTest   0.500682749669068           1.43936557287816E-03
1.2.1 Lap1     0.100088742066873           2.34935650951229E-04
1.2.2 Lap2     0.100127727018844           2.38013410125859E-04
1.2.3 Lap3     0.100125675184245           2.53402205999009E-04
1.2.4 Lap4     0.100125675184245           2.53402205999009E-04
1.2.5 Lap5     0.10012362334237            2.50324446824379E-04


NB. DoSomeHeavyWork here was just a pause of length seconds

Sub DoSomeHeavyWork(Optional length As Single = 0.5)
Dim startTime As Single
startTime = Timer
Do Until Timer - startTime > length
'DoEvents
Loop
End Sub


### Labels

You can see how the test code makes use of labels to enclose portions of the code. Think of labels like brackets, you can OpenLabel and CloseLabel and partition the code into sections like that, the stopwatch measures time between the brackets.

.Start and .Finish are just labels with default name, equivalent to .OpenLabel("Start") and .CloseLabel respectively.

.Lap is a special kind of label. Rather than needing to open and close, laps are used to characterise loops. They measure time relative to the previous label (be it an openLabel/Start or another Laplabel)

Nested labels are considered child nodes in the tree of hierarchy, so "HeavyWork" is a child of the "Start" label. Lap labels are special and can't have child nodes; i.e. you can't make a sub label within a lap measurement (behaviour which I may change, but can be worked around by using a normal label instead)

With this bracket model the code becomes (Laps open and close their own brackets, except Lap1)

Start(
HeavyWork(
)
LoopTest(
Lap1)
(Lap2)
(Lap3)
(Lap4)
(Lap5)
)
)


### How the timing works

The idea was to ensure that the time recorded for a given run was independent of the presence of the stopwatch class. For that reason whenever the class is accessed, it mesures a time-in and a time-out (i.e., it times anything it does between receiving control and handing it back to the caller). This time is subtracted from overall execution time to reduce the impact of of the class on timing results.

The time registered on a label is therefore:

(Time into close label) - (Time out of open label) - (Time wasted by stopwatch class in all child nodes)


## Implementation

To add all of these modules to a project at once, add and run the extract method of this compressed file. You'll need to allow programmatic access to the project

### Stopwatch class

Class to generate label tree hierarchy (Start,OpenLabel,CloseLabel,Lap,Finish), and calculate timestamps (MicroTimer) at each label. These are stored in a dictionary using keys based on the location of a label within the tree

Option Explicit

Private Type TStopWatch
data As Object
CurrentLabel As LabelTree
Results As StopwatchResults
FirstLabel As LabelTree
End Type

Private this As TStopWatch

Private Declare PtrSafe Function getFrequency Lib "kernel32" _
Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long
Private Declare PtrSafe Function getTickCount Lib "kernel32" _
Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long

Private Function MicroTimer() As Double
'Accurate timing method - stackoverflow.com/a/7116928/6609896
Dim cyTicks1 As Currency
Static cyFrequency As Currency

MicroTimer = 0

If cyFrequency = 0 Then getFrequency cyFrequency

getTickCount cyTicks1

If cyFrequency Then MicroTimer = cyTicks1 / cyFrequency
End Function

Public Sub Start()
OpenLabel "Start"
End Sub

Public Sub Finish()
CloseLabel
Set this.Results = New StopwatchResults
End Sub

Public Property Get Results() As StopwatchResults
Set Results = this.Results
End Property

Public Sub OpenLabel(ByVal labelName As String)
'Save time on arrival
Dim clockTimes As New TimeInfo
clockTimes.TimeIn = MicroTimer

'Define new label, and make it a child of the current label
Dim newNode As New LabelTree
newNode.NodeName = labelName
If Not this.CurrentLabel Is Nothing Then
Set newNode.parentNode = this.CurrentLabel
'1.2.1 format
newNode.Location = this.CurrentLabel.Location & "." & this.CurrentLabel.ChildNodes.Count + 1
Else
newNode.Location = "1"
Set this.FirstLabel = newNode
End If
Set this.CurrentLabel = newNode

Dim dictKey As String
dictKey = newNode.Location & "_open"
this.data(dictKey).TimeOut = MicroTimer
End Sub

Public Sub CloseLabel()
'Save time on arrival
Dim clockTimes As New TimeInfo
clockTimes.TimeIn = MicroTimer

Dim dictKey As String
dictKey = this.CurrentLabel.Location & "_close"

'Close label by setting to parent
Set this.CurrentLabel = this.CurrentLabel.parentNode
this.data(dictKey).TimeOut = MicroTimer
End Sub

Public Sub Lap()
'Save time on arrival
Dim clockTimes As New TimeInfo
clockTimes.TimeIn = MicroTimer

'Define new label, and make it a child of the current label
Dim newNode As New LabelTree
newNode.Location = this.CurrentLabel.Location & "." & this.CurrentLabel.ChildNodes.Count + 1
newNode.NodeName = "Lap" & this.CurrentLabel.ChildNodes.Count + 1 'this.CurrentLabel.NodeName & "_
newNode.LabelType = stp_LapTime

If this.CurrentLabel Is Nothing Then
Err.Description = "No test is currently running to write lap data to"
Err.Raise 5
Else
Set newNode.parentNode = this.CurrentLabel
End If

Dim dictKey As String
dictKey = this.CurrentLabel.Location & "_" & newNode.NodeName
this.data(dictKey).TimeOut = MicroTimer
End Sub

Private Sub Class_Initialize()
Set this.data = CreateObject("Scripting.Dictionary")
End Sub


### LabelTree Class

Each instance of a LabelTree object represents a node. Nodes are arranged in a tree fashion, with parent nodes and child nodes (equivalent to level of nesting of labels). The Enum facilitates different post-processing logic for lap labels vs everything else.

Option Explicit

Public Enum stopwatchLableType
stp_LapTime = 1
stp_Label
stp_Start
stp_Finish
End Enum

Private Type TLabelTree
parentNode As LabelTree
ChildNodes As Collection
NodeName As String
TimeSpent As Double
TimeWasted As Double                         'time used by stopwatch runs
Location As String
LabelType As stopwatchLableType
End Type

Private this As TLabelTree
Public Property Get LabelType() As stopwatchLableType
LabelType = this.LabelType
End Property

Public Property Let LabelType(ByVal value As stopwatchLableType)
this.LabelType = value
End Property

Public Property Get Location() As String
Location = this.Location
End Property

Public Property Let Location(ByVal value As String)
this.Location = value
End Property

Public Property Get TimeSpent() As Double
TimeSpent = this.TimeSpent
End Property

Public Property Let TimeSpent(ByVal value As Double)
this.TimeSpent = value
End Property

Public Property Get TimeWasted() As Double
TimeWasted = this.TimeWasted
End Property

Public Property Let TimeWasted(ByVal value As Double)
this.TimeWasted = value
End Property

Public Property Get ChildNodes() As Collection
Set ChildNodes = this.ChildNodes
End Property

Public Property Set ChildNodes(ByVal value As Collection)
Set this.ChildNodes = value
End Property

Public Property Get NodeName() As String
NodeName = this.NodeName
End Property

Public Property Let NodeName(ByVal value As String)
this.NodeName = value
End Property

Public Property Get parentNode() As LabelTree
Set parentNode = this.parentNode
End Property

Public Property Set parentNode(ByVal value As LabelTree)
Set this.parentNode = value
End Property

Private Sub Class_Initialize()
Set this.ChildNodes = New Collection
End Sub


### TimeInfo Class

Holds a timestamp. The only reason this is a Class and not a Type is because it has to be added to a dictionary.

Option Explicit

Private Type TTimeInfo
TimeIn As Double
TimeOut As Double
End Type

Private this As TTimeInfo

Public Property Get TimeIn() As Double
TimeIn = this.TimeIn
End Property

Public Property Let TimeIn(ByVal value As Double)
this.TimeIn = value
End Property

Public Property Get TimeOut() As Double
TimeOut = this.TimeOut
End Property

Public Property Let TimeOut(ByVal value As Double)
this.TimeOut = value
End Property


### StopwatchResults Class

This class does all the post-processing of the labelTree. It converts raw timestamps into time differences using the logic outlined earlier. It also contains methods to output data. The exact implementation here is likely to change a lot - as I intend to expand the output formats to include .ToFile and .ToSheet. Also there may be some statistics built in for loops.

Option Explicit

Private Type TStopWatchResults
TimeData As Object
LabelData As LabelTree
End Type

Private this As TStopWatchResults

Public Sub LoadData(ByVal TimeData As Object, ByVal LabelData As LabelTree)
Set this.LabelData = LabelData
Set this.TimeData = TimeData
writeTimes this.LabelData
End Sub

Public Property Get ToLabelTree() As LabelTree
Set ToLabelTree = this.LabelData
End Property

Public Property Get RawData() As Object
Set RawData = this.TimeData
End Property

Public Sub ToImmediateWindow()
'Prints time info to immediate window
Dim resultsTree As LabelTree
Set resultsTree = this.LabelData
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
flattenTree resultsTree, dict
Debug.Print "Label name", "Time taken"
Debug.Print String(35, "-")
Dim value As Variant
For Each value In dict.Keys
Debug.Print value, dict(value)(0), dict(value)(1)
Next value
End Sub

Private Sub flattenTree(ByVal treeItem As LabelTree, ByRef dict As Object, Optional ByVal depth As Long = 0)
'recursively converts a results tree to a dictionary of result keys
dict.Add printf("{0} {1}", treeItem.Location, treeItem.NodeName), Array(treeItem.TimeSpent, treeItem.TimeWasted)
If treeItem.ChildNodes.Count > 0 Then
Dim item As Variant
For Each item In treeItem.ChildNodes
flattenTree item, dict, depth + 1
Next
End If
End Sub

Private Sub writeTimes(ByRef labelItem As LabelTree)
'Recursively write absolute time data to time elapsed data

Dim startTimes As TimeInfo
Dim endTimes As TimeInfo

setTimeStamps labelItem, startTimes, endTimes 'get timestamps from dictionary
With labelItem
If .ChildNodes.Count > 0 Then
'has children, work out time spent for each then sum
Dim childLabel As LabelTree
Dim item As Variant

For Each item In .ChildNodes         'recurse deeper
Set childLabel = item
writeTimes childLabel
.TimeWasted = .TimeWasted + childLabel.TimeWasted 'add up child wasted time
Next item
.TimeSpent = endTimes.TimeIn - startTimes.TimeOut - .TimeWasted 'time diff - wasted time
.TimeWasted = .TimeWasted + endTimes.TimeOut - endTimes.TimeIn + startTimes.TimeOut - startTimes.TimeIn
Else                                     'No children
If .LabelType = stp_LapTime Then
.TimeWasted = endTimes.TimeOut - endTimes.TimeIn
Else                                 'find time stamps for opening and closing label
.TimeWasted = endTimes.TimeOut - endTimes.TimeIn + startTimes.TimeOut - startTimes.TimeIn
End If
.TimeSpent = endTimes.TimeIn - startTimes.TimeOut
End If
End With
End Sub

Private Sub setTimeStamps(ByVal labelItem As LabelTree, ByRef startTimes As TimeInfo, ByRef endTimes As TimeInfo)
'writes timestamps byref
With labelItem
Dim startKey As String
Dim endKey As String
'location of timestamps in dictionary
Select Case .LabelType
Case stp_LapTime
Dim keyBase As String
keyBase = .parentNode.Location
Dim lapNumber As Long
lapNumber = Right$(.NodeName, Len(.NodeName) - 3) If lapNumber = 1 Then 'first lap, starts at startKey = printf("{0}_open", keyBase) Else startKey = printf("{0}_Lap{1}", keyBase, lapNumber - 1) 'start at prev lap, end here End If endKey = printf("{0}_Lap{1}", keyBase, lapNumber) Case Else startKey = printf("{0}_open", .Location) endKey = printf("{0}_close", .Location) End Select Set endTimes = this.TimeData(endKey) Set startTimes = this.TimeData(startKey) End With End Sub Private Function printf(ByVal mask As String, ParamArray tokens()) As String 'Format string with by substituting into mask - stackoverflow.com/a/17233834/6609896 Dim i As Long For i = 0 To UBound(tokens) mask = Replace$(mask, "{" & i & "}", tokens(i))
Next
End Function


### My concerns

I would particularly like feedback on a few things:

• Comments and names; I feel like comments are sparse, but maybe naming has made up for those ambiguities?
• User Interface; particularly Labels
• Is there a better name for open and close label to make it obvious what they do?
• How about Laps, do they make sense?
• I could have auto-closed all labels like I did with laps, would this have been cleaner? It would give less control over precisely which portions of code are measured.
• ACCURACY. This is a major concern. I've tried to put everything the class does between 2 MicroTimers, so that class overhead can be subtracted from overall measured time. I ran some tests for loops under different conditions (fixed number of loops, sometimes calling routines in the loop, sometimes measuring time for individual loops) to compare my Stopwatch vs writing MicroTimer to a pre-dimensioned array. These are the results:

Which are a bit cryptic. But essentially it compares Real - MicroTimer+Array times (overall and per lap) to Ck - Stopwatch times. And it shows that when the overhead of the class (Waste) is of the same order of magnitude as the running time for the test, the measurements for stopwatch are about 3-4 times longer than the Real measurements. This means that timings below a precision of 1E-4 ~ 100us are fairly inaccurate.

Can anyone see how to improve the accuracy?

Obviously any and all other feedback is welcome too.

I don't know how useful this review will be as a review, but I want to write it up anyway.

Re:

• How about Laps, do they make sense?
• I could have auto-closed all labels like I did with laps, would this have been cleaner? It would give less control over precisely which portions of code are measured.

The way you handle the Lap appears to make it impossible for a Lap node to have a child node. If you put any labels inside a Lap, the stopwatch doesn't add a node to the Lap node, it just adds another node to the Start node.

I haven't quite figured out exactly what is happening, I just know at a certain point in setTimeStamps (recursed down) the startKey that it's looking for to set startTimes doesn't exist. I think I'm in over my head, I'll try some pictures -

Here it looks for 1Lap_2

But here you'll see that doesn't exist, it went from Lap1 to Lap3

The code that did this is

Option Explicit

Sub test()
Dim clock As New Stopwatch
clock.Start
Dim i As Long
For i = 1 To 10
clock.Lap
testMe clock, "label " & i
Next
clock.Finish
clock.Results.ToImmediateWindow
End Sub

Sub testMe(ByRef clock As Stopwatch, ByVal label As String)
clock.OpenLabel label
'clock.Lap
SaySomething label
clock.CloseLabel
End Sub

Sub SaySomething(ByVal label As String)
MsgBox label
End Sub


If you remove the Clock.Lap in the For loop and un-comment the Clock.Lap in TestMe it works fine.

I was just passing the clock around some procedures, but this will occur in a very simple setup as well -

Sub Test2()
Dim clock As New Stopwatch
clock.Start
Dim i As Long
For i = 1 To 3
clock.Lap
clock.OpenLabel i
MsgBox i
clock.CloseLabel
Next
clock.Finish
End Sub


And the error occurs on the Clock.Finish.

Oh, and that extract method is nearly the coolest thing I've seen in VBA.

• Good spot. It's true that lap labels don't support child nodes. That's because their non standard format makes it a little more complicated to determine which nodes are children and which are siblings. But I think they're a little pointless if I don't add this behaviour in? Either way the workaround is to have an open and close pair in the loop instead. I also notice you put lap at the start of the loop - lap measurements are currently relative to the previous label (the lap ends when you hit the lap label) - I imagine a coach with a stopwatch can tell you the lap time only at the end. – Greedo May 22 '18 at 10:12
• But perhaps measuring relative to the next label (putting lap at the start of the loop) is more intuitive - as you have naturally done. What do you think? I envisage a public stopwatch, perhaps predeclared (default instance attribute) and in personal.xlsb to avoid all the passing around. But then a reset method would be necessary. – Greedo May 22 '18 at 10:17
• PS thanks, the code for compressing projects into a single module seems to be working well, although it won't work with userforms yet. Still early bound and very ugly, but it's next on my list of stuff to finish and maybe post here for a review ;-) I gotta say I think it's pretty swanky – Greedo May 22 '18 at 10:22
• Right, I'm not sure how else the Lap would make sense, I think it's more of an error catching case. I think lap does make sense at the beginning of the loop, like a start lap since your lap didn't start on start. – Raystafarian May 23 '18 at 23:51