VBA Code Profiling

Question

I have wanted a way to do code profiling in VBA for quite some time.

It becomes very complicated to figure out what methods are actually being executed for how long and how often in complex Access applications. A key reason this is complicated is that many form events or function calculations happen very often and not only as the result of code. Form events fire based on other form events or user input, etc.

This is a basic class I am calling Profiler:

Option Compare Database
Option Explicit
Private initTime As Double
Private mProfiledMethod As String
Public Property Let ProfiledMethod(pValue As String)
 mProfiledMethod = pValue
End Property
Private Sub Class_Initialize()
 initTime = GetTickCount
End Sub
Private Sub Class_Terminate()
 GetProfileManager.addMethodCall mProfiledMethod, GetTickCount() - initTime
End Sub

Here is what I am calling a ProfileManager class:

Option Compare Database
Option Explicit
Private m_MethodTotalTimes As Scripting.Dictionary
Private m_MethodTotalCalls As Scripting.Dictionary
Public Sub addMethodCall(p_method As String, p_time As Double)
 If m_MethodTotalTimes.exists(p_method) Then
 m_MethodTotalTimes(p_method) = m_MethodTotalTimes(p_method) + p_time
 m_MethodTotalCalls(p_method) = m_MethodTotalCalls(p_method) + 1
 Else
 m_MethodTotalTimes.Add p_method, p_time
 m_MethodTotalCalls.Add p_method, 1
 End If
End Sub
Public Sub PrintTimes()
 Dim mKey
 For Each mKey In m_MethodTotalTimes.Keys
 Debug.Print mKey & " was called " & m_MethodTotalCalls(mKey) & " times for a total time of " & m_MethodTotalTimes(mKey)
 Next mKey
End Sub
Private Sub Class_Initialize()
 Set m_MethodTotalTimes = New Scripting.Dictionary
 Set m_MethodTotalCalls = New Scripting.Dictionary
End Sub

Here is my main module example. I have several nested methods.

Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private mProfileManager As profileManager
Public Function GetProfileManager() As profileManager
 If mProfileManager Is Nothing Then
 Set mProfileManager = New profileManager
 End If
 Set GetProfileManager = mProfileManager
End Function
Public Sub resetProfileManager()
 Set mProfileManager = Nothing
End Sub
Sub mainProfilerTest()
 'reinit profile manager
 resetProfileManager
 'run some time/tests
 test1
 'print results
 GetProfileManager.PrintTimes
End Sub
Sub test1()
 Dim mProfiler As New Profiler
 mProfiler.ProfiledMethod = "test1"
 Dim i As Long
 For i = 0 To 100
 test2
 Next i
End Sub
Sub test2()
 Dim mProfiler As New Profiler
 mProfiler.ProfiledMethod = "test2"
 test3
 test4
End Sub
Sub test3()
 Dim mProfiler As New Profiler
 mProfiler.ProfiledMethod = "test3"
 Dim i As Long, j As Long
 For i = 0 To 1000000
 j = 1 + 5
 Next i
End Sub
Sub test4()
 Dim mProfiler As New Profiler
 mProfiler.ProfiledMethod = "test4"
 Dim i As Long, j As Long
 For i = 0 To 500000
 j = 1 + 5
 Next i
End Sub

This works alright. I will have to add the two lines of code to create/init each Profiler at the beginning of any method I want to profile, which is not ideal but not terribly awful.

On my machine the raw output is:

test3 was called 101 times for a total time of 640
test4 was called 101 times for a total time of 390
test2 was called 101 times for a total time of 1030
test1 was called 1 times for a total time of 1030

For actual runtime, I am intending on wrapping a ProfileManager over a simple sub which triggers form events. For example I might make a simple sub to Open a form, but do something like:

resetProfileManager
DoCmd.OpenForm "Form Name"
GetProfileManager.PrintTimes

Which will print out all the profiled methods for all the tracked methods.

Alternatively, I can reset the profile manager in the background and mimic user behavior and retrieve the profile at any time in the intermediate window with:

?GetProfileManager.PrintTimes

I am basically looking for feedback on how to make this better. It is pretty rough currently because I don't want to go through all the methods I'd want to profile and start adding this code without having more eyes on this.

• citizenkong: GetTickCount is quite a low-resolution timer. Have a look at this question for a more high-resolution timer using another Windows API function: stackoverflow.com/questions/198409/…
• Caltor: How about using the one already written by Bruce McPherson at nullskull.com/a/1602/profiling-and-optimizing-vba.aspx?

Answer 1

This is pretty good and optimal already. Just a few hints here and there

I would take the

Private Declare Function GetTickCount Lib "kernel32.dll" () As Long

and throw that into the Profiler class due to the class being the only one needing it. Trust me it's easy to forget to declare that on a new project in standard module and annoy the sh** out of yourself.

You seem inconsistent about naming your members. Some subs are camelCase, others are PascalCase. Decide which one you're going to use and apply throughout the code.

Generally, your project encapsulation is very loose. I mean, everything depends on everything if that makes any sense; (see interesting post here)

I would think that ProfileManager should include members like Reset and GetProfileManager. BUT since your Profiler needs to access the manager in its Class_Terminate() event and you can't pass parameters nor can you raise an event to notify the manager that the object is about to get destroyed there isn't any other way to achieve this as far as I know due to your current design...

I played with the code for about 2 hours but my conclusion is based on an assumption that you want to minimize it down to just creating an instance of Profiler and calling one Let property without having to explicitly destroy the instance (2 lines of code currently) ie. relying on the Class_Terminate event - you've already got the best approach and there is not much room for further optimizations.

I am still not quite sure what the purpose of your ResetProfileManager() sub is so currently I find it a bit redundant since you could just do this once:

Private manager As ProfileManager
Sub MainProfilerTest()
 Set manager = New ProfileManager
...

Oh btw. I would have changed the mProfileManager to just manager.. makes things simpler.

And further to the above if you explicitly assign a new ProfilerManager to your manager you could improve the performance a bit by modifying the GetProfileManager by removing unnecessary check:

Public Function GetProfileManager() As ProfileManager
 Set GetProfileManager = manager
End Function

Also, in ProfileManager consider using simpler names like:

Private times As Dictionary
Private calls As Dictionary

And in the Profiler:

Private initTime As Double
Private method As String

I would also add the Class_Terminate event to the ProfileManger and free refs to the Dictionaries

Private Sub Class_Terminate()
 Set times = Nothing
 Set calls = Nothing
End Sub

I think it's matter of preference but generally I don't prefix Dictionary with Scripting. Any decent person who's even a bit familiar with VBA will know that Dictionary is Scripting.Dictionary.

I also considered shortening the declaration to one line using imitation of a static class in combination with parametarised constructors but I've seen your chat message from last night saying that you wouldn't want to do that.

I guess that's about all I can say about your code. Like I said if you didn't mind to explicitly destroy your Profile instances that would completely change the story :)

Answer 2

Thanks for the very good question, @enderland.

I modified your profile method a little bit to better suit my needs and am sharing it here in case it helps anyone else.

There are 3 key changes that I made:

1) This code will work cross-platform (Windows and Mac) by implementing a custom GetTickCount() method (the default API is Windows only), as well as a custom dictionary class, Dict.

2) The option to write the log output to a debug worksheet instead of Debug.Print(), since the latter is limited to the number of lines that can be printed without overflow.

3) The logging handles nesting of function calls differently than OP:

Instead of seeing output like this:

ParentFunction was called 1 times for a total time of 21
ChildFunction was called 2 times for a total time of 20

The output looks like this:

ParentFunction (
 ChildFunction (
 ) 00:00:10.000
 ChildFunction (
 ) 00:00:10.000
) 00:00:21.000

Following is the library code...

CodeProfilerManager Class

Option Explicit
' Class - CodeProfilerManager
' https://codereview.stackexchange.com/q/70247
Private priv_profile_indexes_dict As Dict
Private Const priv_profiles_array_size As Integer = 100
Private priv_profiles_array_count As Long
Private priv_profiles_array() As CodeProfile
Private priv_running_count As Long
Private priv_history_chain As String
Private Sub Class_Initialize()
 Call Reset
End Sub
Public Sub Reset()
 Set priv_profile_indexes_dict = New Dict
 priv_profiles_array_count = 0
 ReDim priv_profiles_array(priv_profiles_array_size)
 priv_running_count = 0
 priv_history_chain = vbNullString
End Sub
Public Function ProfileThis(ByVal profile_id As String) As CodeProfileThis
 Set ProfileThis = New CodeProfileThis
 ProfileThis.manager_index = priv_profiles_array_count
 ' Add index to dict
 If Not priv_profile_indexes_dict.HasKey(profile_id) Then
 Call priv_profile_indexes_dict.Add(New collection, profile_id)
 End If
 Call priv_profile_indexes_dict.Item(profile_id).Add(priv_profiles_array_count)
 ' Set CodeProfile in array
 If (priv_profiles_array_count > UBound(priv_profiles_array)) Then
 ReDim Preserve priv_profiles_array(UBound(priv_profiles_array) + priv_profiles_array_size)
 End If
 Dim profile As New CodeProfile
 profile.id = profile_id
 Set priv_profiles_array(priv_profiles_array_count) = profile
 ' Open history chain
 priv_history_chain = priv_history_chain & String(priv_running_count, vbTab) & profile_id & " (" & vbCrLf
 ' Increment counts
 priv_profiles_array_count = priv_profiles_array_count + 1
 priv_running_count = priv_running_count + 1
End Function
Public Sub ProfileEnd(ByRef profile_this As CodeProfileThis)
 ' This function should never be called except by CodeProfileThis.Class_Terminate()
 ' Update profile
 Dim profile As CodeProfile
 Set profile = priv_profiles_array(profile_this.manager_index)
 profile.ticks_end = globals.GetTickCount()
 profile.is_running = False
 ' Close history chain
 priv_running_count = priv_running_count - 1
 priv_history_chain = priv_history_chain & String(priv_running_count, vbTab) & ") " & TicksToTimeString(profile.ticks_elapsed) & vbCrLf
End Sub
Public Sub PrintHistory()
 Debug.Print priv_history_chain
End Sub
Public Sub WriteHistory()
 If (priv_history_chain <> vbNullString) Then
 ' Split history on newline char and replace tabs with 4xSpaces
 Dim history_split() As String
 history_split = Split(Replace$(priv_history_chain, vbTab, " "), vbCrLf)
 ' Write the history
 Call WriteTextToDebugSheet("Code Profile", history_split)
 End If
End Sub

CodeProfile Class

Option Explicit
' Class - CodeProfile
' You should never use this class directly!
' Use globals.code_profile_manager.ProfileThis()
Private priv_id As String
Private priv_is_running As Boolean
Private priv_ticks_start As Long
Private priv_ticks_end As Long
Private Sub Class_Initialize()
 priv_ticks_start = globals.GetTickCount()
 priv_is_running = True
End Sub
Public Property Let id(id As String)
 priv_id = id
End Property
Public Property Get id() As String
 id = priv_id
End Property
Public Property Let is_running(ByVal true_or_false As Boolean)
 priv_is_running = true_or_false
End Property
Public Property Get is_running() As Boolean
 is_running = priv_is_running
End Property
Public Property Let ticks_end(ByVal ticks As Long)
 priv_ticks_end = ticks
End Property
Public Property Get ticks_end() As Long
 ticks_end = priv_ticks_end
End Property
Public Property Get ticks_start() As Long
 ticks_start = priv_ticks_start
End Property
Public Property Get ticks_elapsed() As Long
 ticks_elapsed = priv_ticks_end - priv_ticks_start
End Property

CodeProfileThis Class

Option Explicit
' Class - CodeProfileThis
' You should never use this class directly!
' Use globals.code_profile_manager.ProfileThis()
Private priv_manager_index As Long
Public Property Let manager_index(ByVal i As Long)
 priv_manager_index = i
End Property
Public Property Get manager_index() As Long
 manager_index = priv_manager_index
End Property
Private Sub Class_Terminate()
 Call globals.code_profile_manager.ProfileEnd(Me)
End Sub

Dict Class

Option Explicit
' Class - Dict
Private priv_keys As New collection
Private priv_values As New collection
Public Property Get Keys() As collection
 Set Keys = priv_keys
End Property
Public Property Get Values() As collection
 Set Values = priv_values
End Property
Public Sub Add( _
 ByVal val As Variant, _
 ByVal key As String _
 )
 Call priv_values.Add(val, key)
 Call priv_keys.Add(key)
End Sub
Public Function Item(ByVal key As String) As Variant
 Call SetThisToThat(Item, priv_values.Item(key))
End Function
Public Function HasKey(ByVal key As String) As Boolean
 HasKey = CollectionHasKey(priv_values, key)
End Function
Public Property Get Count() As Integer
 Count = priv_keys.Count
End Property
Public Sub Remove(ByVal key As String)
 Dim n As Long
 n = GetIndexOfCollectionValue(priv_keys, key)
 Call priv_values.Remove(key)
 Call priv_keys.Remove(n)
End Sub
Public Function Pop(ByVal key As String) As Variant
 Dim n As Long
 n = GetIndexOfCollectionValue(priv_keys, key)
 Call SetThisToThat( _
 Pop, _
 priv_values.Item(key) _
 )
 Call priv_values.Remove(key)
 Call priv_keys.Remove(n)
End Function

GlobalsClass Class

Option Explicit
' Class - GlobalsClass
Private Const priv_is_debug_mode As Boolean = True
Private Const priv_debug_sheet_name As String = "Debug"
Private priv_start_datetime As Double ' store as double
Private priv_code_profile_manager As New CodeProfileManager
Private Sub Class_Initialize()
 priv_start_datetime = Evaluate("Now()")
End Sub
Public Function GetTickCount() As Long
 ' returns number of milliseconds since priv_start_datetime
 '
 ' similar to API GetTickCount, but works on both Windows and Mac
 ' https://docs.microsoft.com/en-us/windows/desktop/api/sysinfoapi/nf-sysinfoapi-gettickcount
 '
 ' the difference is that the API returns number of milliseconds since boot,
 ' but this function returns number of milliseconds since this class was initialized
 GetTickCount = CLng( _
 (Evaluate("Now()") - priv_start_datetime) * 86400000 _
 )
End Function
Public Property Get code_profile_manager() As CodeProfileManager
 Set code_profile_manager = priv_code_profile_manager
End Property
Public Property Get is_debug_mode() As Boolean
 is_debug_mode = priv_is_debug_mode
End Property
Public Property Get debug_sheet_name() As String
 debug_sheet_name = priv_debug_sheet_name
End Property

Main Module

Option Explicit
' Module - Main
Public globals As New GlobalsClass
Sub WriteCodeProfileHistory()
 Call globals.code_profile_manager.WriteHistory
End Sub
Public Function TicksToTimeString(ByVal milliseconds As Long) As String
 ' converts milliseconds to "human-readable" format of
 ' hh:mm:ss.mmm
 Dim hours As Long
 Dim minutes As Long
 Dim seconds As Long
 hours = milliseconds \ 3600000
 milliseconds = milliseconds - hours * 3600000
 minutes = milliseconds \ 60000
 milliseconds = milliseconds - minutes * 60000
 seconds = milliseconds \ 1000
 milliseconds = milliseconds - seconds * 1000
 If (hours >= 10) Then
 TicksToTimeString = hours
 Else
 TicksToTimeString = "0" & hours
 End If
 TicksToTimeString = _
 TicksToTimeString & ":" & _
 Right$("0" & minutes, 2) & ":" & _
 Right$("0" & seconds, 2) & "." & _
 Right$("00" & milliseconds, 3)
End Function
Sub SetThisToThat(ByRef this As Variant, ByVal that As Variant)
 ' Used if "that" can be an object or a primitive
 If IsObject(that) Then
 Set this = that
 Else
 this = that
 End If
End Sub
Function GetIndexOfCollectionValue( _
 ByVal c As collection, _
 ByVal val As Variant _
 ) As Long
 Dim n As Long
 For n = 1 To c.Count
 If (c.Item(n) = val) Then
 Exit For
 End If
 Next n
 If (n > c.Count) Then
 err.Raise 5, _
 "GetIndexOfCollectionValue", _
 "There is no value of " & val
 End If
 GetIndexOfCollectionValue = n
End Function
Function CollectionHasKey( _
 ByVal c As collection, _
 ByVal key As String _
 ) As Boolean
 CollectionHasKey = True
 On Error GoTo no
 Call IsObject(c.Item(key))
 Exit Function
no:
 CollectionHasKey = False
End Function
Public Function SheetExists(ByVal sheet_name As String) As Boolean
 ' https://stackoverflow.com/a/6040390
 SheetExists = True
 On Error GoTo no
 Call IsObject(ActiveWorkbook.Sheets(sheet_name))
 Exit Function
no:
 SheetExists = False
End Function
Private Function GetDebugSheet() As Worksheet
 If SheetExists(globals.debug_sheet_name) Then
 Set GetDebugSheet = ActiveWorkbook.Sheets(globals.debug_sheet_name)
 Else
 Dim active_sheet As Worksheet
 Set active_sheet = ActiveWorkbook.ActiveSheet
 Set GetDebugSheet = ActiveWorkbook.Worksheets.Add( _
 Before:=globals.base_workbook.Sheets(1) _
 )
 GetDebugSheet.name = globals.debug_sheet_name
 Call active_sheet.Activate
 End If
End Function
Sub WriteTextToDebugSheet( _
 ByVal column_title As String, _
 ByRef text_array() As String _
 )
 ' Looks for "column_title" text in row 1 of globals.debug_sheet_name
 ' If found, write array to column
 ' Else, write to new column with "column_title"
 Dim debug_sheet As Worksheet
 Set debug_sheet = GetDebugSheet()
 Dim header_row_i As Long
 header_row_i = 1
 Dim found_header_str As String
 Dim target_column_i As Long
 target_column_i = 1
 Do While True
 found_header_str = debug_sheet.Cells(header_row_i, target_column_i).Value2
 If (found_header_str = column_title) Or (found_header_str = vbNullString) Then
 Exit Do
 End If
 target_column_i = target_column_i + 1
 Loop
 ' Set target info
 Dim target_column_str As String
 Dim target_row_i As Long
 target_column_str = ColumnIndexAsChar(target_column_i)
 target_row_i = header_row_i + 1
 ' Clear current contents of target column
 debug_sheet.Range(target_column_str & ":" & target_column_str) _
 .Value2 = vbNullString
 ' Update header
 With debug_sheet.Cells(header_row_i, target_column_i)
 .Value2 = column_title
 .Font.Bold = True
 .Font.Underline = xlUnderlineStyleSingle
 .VerticalAlignment = xlCenter
 End With
 ' Write text_array to target column
 debug_sheet.Range( _
 target_column_str & target_row_i, _
 target_column_str & (target_row_i + ArrayLength(text_array) - 1) _
 ) _
 .Value2 = WorksheetFunction.Transpose(text_array)
End Sub
Public Function ArrayLength(ByVal a As Variant) As Long
 ' https://stackoverflow.com/a/30574874
 ArrayLength = UBound(a) - LBound(a) + 1
End Function

Example Usage:

Sub ParentFunction()
 If globals.is_debug_mode Then
 Dim code_profiler As CodeProfileThis
 Set code_profiler = globals.code_profile_manager.ProfileThis("ParentFunction")
 End If
 Call ChildFunction
 Call ChildFunction
 Call Application.Wait(Now + TimeValue("0:00:01"))
End Sub
Sub ChildFunction()
 If globals.is_debug_mode Then
 Dim code_profiler As CodeProfileThis
 Set code_profiler = globals.code_profile_manager.ProfileThis("ChildFunction")
 End If
 Call Application.Wait(Now + TimeValue("0:00:10"))
End Sub

You can fetch/view the log by one of 2 methods:

1) Call WriteCodeProfileHistory will write the log to WorkSheet globals.debug_sheet_name (and create it if it does not exist)

or

2) Call globals.code_profile_manager.PrintHistory will use Debug.Print

Method #2, Debug.Print, will work fine for the simple example of ParentFunction and ChildFunction (since the output is very small), but you will want to use #1 if the output is larger and cannot all fit into the debug window.

Answer 3

Maybe use vba.timer rather than an API call? It returns the time as a double that includes milliseconds.

• mdfst13: But why would you want a "double that includes milliseconds" rather than whatever is provided now? Please remember, the goal here is to review the existing code. In this case, that would mean describing what is not good about the existing API call rather than merely offering an alternative implementation. I'm also having trouble confirming the spelling/capitalization of vba.timer -- what I'm finding instead is Timer which returns a Single that has fractional precision only in Windows.
• vbAdder: @mdfst13 you are correct, I just wanted to hightlight that on the mac the vba.timer function now does give fractions as well, with a resolution of 10 ms. (excel v16.58 which has vba7.1) also, the timer function is about 100 times faster then evaluate("now()"). The latter has the same resolution. gettickcount is faster then timer, with a resolution of 1 ms.
• vbAdder: @mdfst13, I have written a program to test the different timers mentionned in this post. I have to say I would no longer use timer, as its resolution goes down as the day passes!! see codereview.stackexchange.com/questions/275531/…. THe best timers are based on the QueryPerformanceCounter function (also mentioned previously). I managed to get this working on a mac by referencing the mso22 framework.