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.

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.