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
this.Results.LoadData this.data, this.FirstLabel
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
this.CurrentLabel.ChildNodes.Add newNode, newNode.Location & newNode.NodeName
Else
newNode.Location = "1"
Set this.FirstLabel = newNode
End If
Set this.CurrentLabel = newNode
'Save time data to dictionary and return to execution
Dim dictKey As String
dictKey = newNode.Location & "_open"
this.data.Add dictKey, clockTimes
this.data(dictKey).TimeOut = MicroTimer
End Sub
Public Sub CloseLabel()
'Save time on arrival
Dim clockTimes As New TimeInfo
clockTimes.TimeIn = MicroTimer
'Save time data to dictionary and return to execution
Dim dictKey As String
dictKey = this.CurrentLabel.Location & "_close"
this.data.Add dictKey, clockTimes
'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
this.CurrentLabel.ChildNodes.Add newNode, newNode.NodeName
End If
'Save time data to dictionary and return to execution
Dim dictKey As String
dictKey = this.CurrentLabel.Location & "_" & newNode.NodeName
this.data.Add dictKey, clockTimes
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
printf = mask
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 myStopwatchvs writingMicroTimerto 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.
