# VBA Code Profiling

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()
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
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.

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 :)

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

End If

' 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

ByVal c As collection, _
ByVal key As String _
) As Boolean

On Error GoTo no
Call IsObject(c.Item(key))
Exit Function
no:
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

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 target_column_i As Long
target_column_i = 1
Do While True
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)

' Clear current contents of target column
debug_sheet.Range(target_column_str & ":" & target_column_str) _
.Value2 = vbNullString

.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.