asked on

Dynamically modify/instrument code in a module at design time

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,

-g

ASKER CERTIFIED SOLUTION

BrianGEFF719

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

OuttaCyTE

ASKER

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.

-g

********* 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
Loop
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

OuttaCyTE

ASKER

BrianGEFF719,

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?

List,

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.

OuttaCyTE

ASKER

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