Dynamically modify/instrument code in a module at design time

Posted on 2006-05-22
Last Modified: 2010-05-01
Hello VB/VBA experts,

Having futzed around with coding some stuff in Access VBA, I find that the debugging/logging functions are inadequate.  I have written a few public routines that help figure out what went wrong by capturing my entry & exit events and a few other items.  The problem is maintaining the code instrumentation as I add, delete and restructure the program code itself.

What I would like to be able to do, while running the IDE, is to be able to execute a piece of code that can update the modules of the project to maintain the code instrumenation.

Surely there is a way to do this?

Where would I look for examples?  I will increase points as appropriate if this question gets into some gory details and/or significant code examples.

Thanks everyone,

Question by:OuttaCyTE
    LVL 19

    Accepted Solution

    You can create an addin, see:

    Author Comment

    Here is the code that I have roughed together to create my InstrumentMe module.  Simple paste this into a module named "InstrumentMe" (case is important) and have a go.

    I make no warranties to the correctness or usefullness of this code.  I would recommend you treat it as buggy code and backup before you try it on code you don't want trashed.

    I would appreciate anyone making updates, fixes, improvements to send me a copy.  Send to Contact  "the shifted 2"  If you find this useful, post me a note.

    I commented out the actual save so that somebody running this without reading won't actually change their code.


    ********* cut and paste into a module named InstrumentMe *****  Run the InstrumentMe routine from the IDE ********  Good Luck
    Option Compare Database
    Option Explicit
        Dim myOldCode As String
        Dim myNewCode As String

    Private Sub InstrumentMe()
        Dim myModule As Module
        Dim myComponent As Object 'a VBComponent
        'Dim nWhereFound As Long
        Dim oRegExpOuter As RegExp
        Dim oMatchCollOuter As MatchCollection
        Dim oMatchOuter As Match
        Dim nRemainderOffset
        Dim nIndex As Long
        Set oRegExpOuter = New RegExp
        oRegExpOuter.Global = True
        oRegExpOuter.IgnoreCase = True
        'form? = type 100, codemodule = type 1,
        For Each myComponent In VBE.ActiveVBProject.VBComponents
            If myComponent.Type = 1 And myComponent.Name <> "InstrumentMe" Then
                Do While True ' infinite loop here.  Must provide exit.  All because you can't "Next" inside an If/End If pair
                    Debug.Print myComponent.Name
                    myNewCode = ""
                    DoCmd.OpenModule myComponent.Name
                    Set myModule = Modules(myComponent.Name)
                    myOldCode = myModule.Lines(1, myModule.CountOfLines)
                    'myOldCode = "prefix stuff" & vbCrLf & "'dbgInstrumentMe:Off" & vbCrLf & _
                                "Sub SamSpade(pvar1, optional pvar2 as type) as Returnvartype ...." & vbCrLf & _
                                "somecode" & vbCrLf & "Exit Function" & vbCrLf & _
                                "End something not function or sub" & vbCrLf & _
                                "End Sub ..." & vbCrLf & _
                                "" & vbCrLf & _
                                "Friend Static Function SamSpade2(pvar1, optional pvar2 as type) as Returnvartype ...." & vbCrLf & _
                                "somecode" & vbCrLf & "Exit Function" & vbCrLf & _
                                "End something not function or sub" & vbCrLf & _
                                "End Function ..." & vbCrLf & _
                                "Property Get SamSpadexx(pvar1, optional pvar2 as type) as Returnvartype ...." & vbCrLf & _
                                "somecode" & vbCrLf & "Exit Property" & vbCrLf & _
                                "End something not function or sub" & vbCrLf & _
                                "End Property ..." & vbCrLf & _
                                "Public Property Get SamSpadexx(pvar1, optional pvar2 as type) as Returnvartype ...." & vbCrLf & _
                                "somecode" & vbCrLf & "Exit Property" & vbCrLf & _
                                "End something not function or sub" & vbCrLf & _
                                "End Property ..." & vbCrLf & _
                                "Function SamSpade3(pvar1, optional pvar2 as type) as Returnvartype ...." & vbCrLf & _
                                "somecode" & vbCrLf & "Exit Function" & vbCrLf & _
                                "End something not function or sub" & vbCrLf & _
                                "End Function ..." & vbCrLf & "and some stuff on the end"
                    'Debug.Print myOldCode
                    myOldCode = Replace(myOldCode, vbCrLf, Chr(8)) ' change cr/lf to something else not normally found in code
                    'Debug.Print myOldCode
                    'this regex creates a set of matches.  Each match has "prefix stuff" and one entire Function/Sub routine (ending with the line containing End Function/End Sub)
                    'There are six submatches per match.
                    '   0) The "prefix stuff" before the Function/Sub - ends with chr(8)  - note that if this is the second or following match it may have some leading chr(8) characters as well.
                    '      Prefix stuff is where the declarations will be as well as non-sub and non-function (e.g. property routines) will end up.
                    '   1) Private, Public, Friend, or ""
                    '   2) Static or ""
                    '   3) Sub or Function
                    '   4) The function except for the End Sub/Function line.  Has a leading space
                    '   5) The End Sub/Function line
                    'At the end, after looping through the match sets, there will be a remainder which is not represented in any of the matches.
                    'Grab this by getting the offset of the last match + length of last match
                    oRegExpOuter.pattern = "(.*?)" & Chr(8) & "(Private|Public|Friend)?[ ]?(Static)?[ ]?(Sub|Function){1}(.*?)(End \4[^" & Chr(8) & "]*){1}"
                    Set oMatchCollOuter = oRegExpOuter.Execute(myOldCode)
                    'Debug.Print "there are " & oMatchCollOuter.Count & " matches in the collection"
                    'Debug.Print oMatchCollOuter.Item(0).SubMatches.Item(0)
                    If InStr(oMatchCollOuter.Item(0).SubMatches.Item(0), "InstrumentMe:Off") Then
                        DoCmd.Close acModule, myComponent.Name, acSaveNo
                        Exit Do ' no instrumenting desired for this module
                    End If
                    For Each oMatchOuter In oMatchCollOuter
                        'Debug.Print "Match: " & oMatchOuter.Value ' the contents of this match
                        'Debug.Print oMatchOuter.FirstIndex ' the index into the original string for this match
                        'Debug.Print oMatchOuter.Length ' the length of this match (length of value)
                        '                                         'submatches are not a match collection
                        'Debug.Print oMatchOuter.SubMatches.Count 'the count of submatches
                        'For nIndex = 0 To oMatchOuter.SubMatches.Count - 1
                        '    Debug.Print "Item(" & nIndex & "): " & oMatchOuter.SubMatches.Item(nIndex)
                        'Next nIndex
                        nRemainderOffset = oMatchOuter.FirstIndex + oMatchOuter.Length + 2
                        instrumentRoutines oMatchOuter.SubMatches.Item(0), _
                                            Trim(Trim(oMatchOuter.SubMatches.Item(1) & " " & oMatchOuter.SubMatches.Item(2) & " ") & " " & _
                                            oMatchOuter.SubMatches.Item(3)) & oMatchOuter.SubMatches.Item(4) & _
                                            oMatchOuter.SubMatches.Item(5), _
                                            oMatchOuter.SubMatches.Item(3), _
                                            myComponent.Name, _
                                            Trim(Left(oMatchOuter.SubMatches.Item(4), InStr(oMatchOuter.SubMatches.Item(4), "(") - 1))
                    Next 'get the next match
                    'handle the remainder
                    'Debug.Print Mid(myOldCode, nRemainderOffset)
                    myNewCode = myNewCode & Replace(Mid(myOldCode, nRemainderOffset), Chr(8), vbCrLf) ' just copy it as is
                    'When you are comfortable with the code, you can comment the next two and uncomment the following block
                    'and this thing will instrument your code.
                    'I suggest you backup first and I accept no liabilities for this rough piece of code!!
                    Debug.Print myNewCode
                    DoCmd.Close acModule, myComponent.Name, acSaveNo
                    'now, replace all of the lines in the module with the new code !!!!
                    'myModule.DeleteLines 1, myModule.CountOfLines ' all of them
                    'myModule.InsertLines 1, myNewCode
                    'DoCmd.Close acModule, myComponent.Name, acSaveYes
                    Exit Do 'exit do loop at bottom
            End If
        Next myComponent ' go get the next module

    End Sub

    Private Sub instrumentRoutines(pPrefix As String, pRoutine As String, pType As String, pModuleName As String, pRoutineName As String)
        Dim myLines() As String ' holds my old lines
        Dim myNewLines() As String 'holds my new lines
        Dim myNewLinesSize As Long
        Dim nCurrLine As Long ' index into old lines
        Dim nNewLine As Long ' index into new lines, next place to insert
        Dim bInstrumentRoutine As Boolean
        Dim nWhereFound As Long
        Dim sExitString As String
        Dim sEndString As String
        Dim sEndStringSize As Long
        'Debug.Print "Prefix: " & pPrefix
        'Debug.Print "Code: " & pRoutine
        'Debug.Print "Type: " & pType
        'Debug.Print "Module: " & pModuleName
        'Debug.Print "Routine: " & pRoutineName
        myNewCode = myNewCode & Replace(pPrefix, Chr(8), vbCrLf) & vbCrLf ' just copy it as is, supply dropped cr/lf
        myLines = Split(pRoutine, Chr(8))
        bInstrumentRoutine = True
        nNewLine = 0
        myNewLinesSize = fArraySize(myLines) + 50
        ReDim myNewLines(myNewLinesSize)
        sExitString = "Exit " & pType
        sEndString = "End " & pType
        sEndStringSize = Len(sEndString)
        ' handle the first line
        If InStr(myLines(LBound(myLines)), "dbgInstrumentMe:Off") Then
            bInstrumentRoutine = False
        End If
        myNewLines(nNewLine) = myLines(LBound(myLines))
        myNewLines(nNewLine + 1) = "    dbgEntry (""" & pModuleName & "." & pRoutineName & """)"
        nNewLine = nNewLine + 2

        For nCurrLine = LBound(myLines) + 1 To UBound(myLines)
            'this routine could use some improvement.  For now, you cannot comment an Exit Sub/Function or End Sub/Function statements
            'The Exit Sub/Function cannot be in an if xxx then yyy else zzz type statement.  Must use end if type structure
            'the dbgEntry and dbgExit statements must be on separate lines.
            If InStr(myLines(nCurrLine), "dbgEntry (") Or InStr(myLines(nCurrLine), "dbgExit (") Then
                nNewLine = nNewLine ' do nothing
            Else ' we have an old dbgEntry or dbgExit lines, just drop it
                If bInstrumentRoutine Then
                    If (nNewLine + 2) >= myNewLinesSize Then
                        myNewLinesSize = myNewLinesSize + 50
                        ReDim Preserve myNewLines(myNewLinesSize)
                    End If
                    nWhereFound = InStr(myLines(nCurrLine), sExitString)
                    If nWhereFound Then
                        myNewLines(nNewLine) = Space(nWhereFound - 1) & "dbgExit (""" & pModuleName & "." & pRoutineName & """)"
                        myNewLines(nNewLine + 1) = myLines(nCurrLine)
                        nNewLine = nNewLine + 2
                    ElseIf Left(myLines(nCurrLine), sEndStringSize) = sEndString Then
                        myNewLines(nNewLine) = "    dbgExit (""" & pModuleName & "." & pRoutineName & """)"
                        myNewLines(nNewLine + 1) = myLines(nCurrLine)
                        nNewLine = nNewLine + 2
                    Else ' nothing special, just copy over
                        myNewLines(nNewLine) = myLines(nCurrLine)
                        nNewLine = nNewLine + 1
                    End If
                Else ' not instrumenting, just copy over
                    myNewLines(nNewLine) = myLines(nCurrLine)
                    nNewLine = nNewLine + 1
                End If
            End If
        Next 'grab next line
        'add what we have into the myNewCode string
        ReDim Preserve myNewLines(nNewLine) ' truncate the array to just those that we filled
        myNewCode = myNewCode & Join(myNewLines, vbCrLf)

    End Sub

    Private Function fMax(pLeft As Variant, pRight As Variant) As Variant
        If pLeft > pRight Then fMax = pLeft Else fMax = pRight
    End Function

    Private Function fMin(pLeft As Variant, pRight As Variant) As Variant
        If pLeft < pRight Then fMin = pLeft Else fMin = pRight
    End Function

    Private Function fArraySize(pArray)
        fArraySize = UBound(pArray) - LBound(pArray) + 1
    End Function

    Author Comment


    Thanks for responding.  I've taken a look at the link.  Does creating an add-in require the full VB, or can it be done in Access VBA?


    I've got some more updates to the routine.  The above code works for non-form modules only.  Also, it adds a line after every sub/function.  I've got those resolved.  I'll probably close this in a few days if no one is interested.

    Author Comment

    Brian gets the points because he responded.  Grade B because no followup

    Write Comment

    Please enter a first name

    Please enter a last name

    We will never share this with anyone.

    Featured Post

    How to run any project with ease

    Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
    - Combine task lists, docs, spreadsheets, and chat in one
    - View and edit from mobile/offline
    - Cut down on emails

    Introduction I needed to skip over some file processing within a For...Next loop in some old production code and wished that VB (classic) had a statement that would drop down to the end of the current iteration, bypassing the statements that were c…
    I was working on a PowerPoint add-in the other day and a client asked me "can you implement a feature which processes a chart when it's pasted into a slide from another deck?". It got me wondering how to hook into built-in ribbon events in Office.
    Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
    This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

    760 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    6 Experts available now in Live!

    Get 1:1 Help Now