The Microsoft Visual Basic for Applications Extensibility library let's us meta-program VBA, but the way it handles (or rather, doesn't handle) getting to the actual subs and functions is clunky at best. I decided to write a few class modules to make it easier.
Considering this can be kind of dangerous to do, I want to know that it's working the way I think it does without unintended side effects. Of course, I'm also interested in other feedback. I'd like to gauge if I've learned anything over the last few days here. I feel like I have the logic and style pretty tight, so I'm particularly interested in hearing thoughts on how I handled the object model.
There are three classes:
- vbeProcedure - does most of the heavy lifting of getting us the procedures.
- vbeProcedures - Simple collection class that holds only the vbeProcedure type.
- vbeCodeModule - Ties the VBIDE.CodeModule object to a vbeProcedures collection (as well as actually creating that collection.)
The project requires references to both the Microsoft Visual Basic for Applications Extensibility 5.3 and Microsoft Access 14.0 Object libraries.
vbeCodeModule
Option Compare Database
Option Explicit
Private mCodeModule As CodeModule
Private mVbeProcedures As VbeProcedures
Public Property Get CodeModule() As CodeModule
Set CodeModule = mCodeModule
End Property
Public Property Let CodeModule(ByRef CodeMod As CodeModule)
Me.Initialize CodeMod
End Property
Public Property Get VbeProcedures()
Set VbeProcedures = mVbeProcedures
End Property
Public Sub Initialize(CodeMod As CodeModule)
Set mCodeModule = CodeMod
Set mVbeProcedures = getProcedures(mCodeModule)
End Sub
Private Sub Class_Terminate()
Set mVbeProcedures = Nothing
Set mCodeModule = Nothing
End Sub
Private Function getProcedures(CodeMod As CodeModule) As VbeProcedures
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Returns collection of all vbeProcedures in a CodeModule '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim procName As String
Dim lastProcName As String
Dim procs As New VbeProcedures
Dim proc As vbeProcedure
Dim i As Long
' Skip past any Option statement
' and any module-level variable declations.
For i = CodeMod.CountOfDeclarationLines + 1 To CodeMod.CountOfLines
' get procedure name
procName = CodeMod.ProcOfLine(i, vbext_pk_Proc)
If Not procName = lastProcName Then
' create new procedure object
Set proc = New vbeProcedure
proc.Initialize procName, CodeMod
' add it to collection
procs.Add proc
' reset lastProcName
lastProcName = procName
End If
Next i
Set getProcedures = procs
End Function
vbeProcedures
Option Compare Database
Option Explicit
Private mCollection As Collection
Public Sub Clear()
killVbeProcs
Set mCollection = New Collection
End Sub
Public Function Add(ByRef vbeProc As vbeProcedure, Optional ByVal Key As Variant)
If IsMissing(Key) Then
mCollection.Add vbeProc
Else
mCollection.Add vbeProc, Key
End If
End Function
Public Function Remove(ByVal Index As Variant)
mCollection.Remove (Index)
End Function
Public Function Item(ByVal Index As Variant) As vbeProcedure
Set Item = mCollection(Index)
End Function
Public Function Count() As Long
Count = mCollection.Count
End Function
Public Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Set NewEnum = mCollection.[_NewEnum]
End Function
Private Sub Class_Initialize()
Set mCollection = New Collection
End Sub
Private Sub Class_Terminate()
killVbeProcs
Set mCollection = Nothing
End Sub
Private Sub killVbeProcs()
Dim proc As vbeProcedure
If Not mCollection Is Nothing Then
For Each proc In mCollection
Set proc = Nothing
Next proc
End If
End Sub
vbeProcedure
Option Compare Database
Option Explicit
' error handling values
Private Const BaseErrorNum As Long = 3500
Public Enum vbeProcedureError
vbeObjectNotIntializedError = vbObjectError + BaseErrorNum
vbeReadOnlyPropertyError
End Enum
Private Const ObjectNotIntializedMsg = "Object Not Initialized"
Private Const ReadOnlyPropertyMsg = "Property is Read-Only after initialization"
' exposed property variables
Private mParentModule As CodeModule
Private mName As String
' truly private property variables
Private isNameSet As Boolean
Private isParentModSet As Boolean
Public Property Get Name() As String
If isNameSet Then
Name = mName
Else
RaiseObjectNotIntializedError
End If
End Property
Public Property Let Name(ByVal vNewValue As String)
If Not isNameSet Then
mName = vNewValue
isNameSet = True
Else
RaiseReadOnlyPropertyError
End If
End Property
Public Property Get ParentModule() As CodeModule
If isParentModSet Then
Set ParentModule = mParentModule
Else
RaiseObjectNotIntializedError
End If
End Property
Public Property Let ParentModule(ByRef vNewValue As CodeModule)
If Not isParentModSet Then
Set mParentModule = vNewValue
isParentModSet = True
Else
RaiseReadOnlyPropertyError
End If
End Property
Public Property Get startLine() As Long
If isParentModSet And isNameSet Then
startLine = Me.ParentModule.ProcStartLine(Me.Name, vbext_pk_Proc)
Else
RaiseObjectNotIntializedError
End If
End Property
Public Property Get EndLine() As Long
If isParentModSet And isNameSet Then
EndLine = Me.startLine + Me.CountOfLines
Else
RaiseObjectNotIntializedError
End If
End Property
Public Property Get CountOfLines() As Long
If isParentModSet And isNameSet Then
CountOfLines = Me.ParentModule.ProcCountLines(Me.Name, vbext_pk_Proc)
Else
RaiseObjectNotIntializedError
End If
End Property
Public Sub Initialize(Name As String, CodeMod As CodeModule)
Me.Name = Name
Me.ParentModule = CodeMod
End Sub
Public Property Get Lines() As String
If isParentModSet And isNameSet Then
Lines = Me.ParentModule.Lines(Me.startLine, Me.CountOfLines)
Else
RaiseObjectNotIntializedError
End If
End Property
Private Sub RaiseObjectNotIntializedError()
Err.Raise vbeProcedureError.vbeObjectNotIntializedError, GetErrorSource, ObjectNotIntializedMsg
End Sub
Private Sub RaiseReadOnlyPropertyError()
Err.Raise vbeProcedureError.vbeReadOnlyPropertyError, GetErrorSource, ReadOnlyPropertyMsg
End Sub
Private Function GetErrorSource() As String
GetErrorSource = CurrentProject.Name & "." &TypeName(Me)
End Function
And finally, The example call:
Private Sub exampleCall()
On Error GoTo ErrHandler
Dim prj As vbProject
Set prj = VBE.ActiveVBProject
Dim CodeMod As New vbeCodeModule
CodeMod.Initialize prj.VBComponents("OraConfig").CodeModule
Dim proc As vbeProcedure
For Each proc In CodeMod.vbeProcedures
With proc
Debug.Print "ParentModule: " & .ParentModule.Name
Debug.Print "Name: " & .Name
Debug.Print "StarLine: " & .startLine
Debug.Print "EndLine: " & .EndLine
Debug.Print "CountOfLines: " & .CountOfLines
'uncommenting the next line will print the procedure's contents
'Debug.Print .Lines
' throw an error for fun.
' Sidenote, how can I expose this to vbeCodeModule, but not client code?
.Initialize "ensureSQLNet", prj.VBComponents("OraConfig").CodeModule
End With
Next proc
NormalExit:
Set CodeMod = Nothing
Exit Sub
ErrHandler:
If Err.number = vbeReadOnlyPropertyError Then
MsgBox "That vbeProcedure is already initialized.", vbExclamation, "Warning"
Resume Next
Else
Err.Raise Err.number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Resume NormalExit:
End If
End Sub