Dynamically modify/instrument code in a module at design time

Posted on 2006-05-22
Medium Priority
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
  • 3
LVL 19

Accepted Solution

BrianGEFF719 earned 375 total points
ID: 16740173
You can create an addin, see:


Author Comment

ID: 16748563
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" outtacyte.com.  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

ID: 16766150

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

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

Featured Post

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction In a recent article (http://www.experts-exchange.com/A_7811-A-Better-Concatenate-Function.html) for the Excel community, I showed an improved version of the Excel Concatenate() function.  While writing that article I realized that no o…
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…
Suggested Courses
Course of the Month15 days, 20 hours left to enroll

850 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