Here is some code to generate code for raising and getting information about
custom errors in an application. Executing the GenerateXyzErrDefs procedure
generates the code.
<tblXyzError>
ErrorCodeOffset (Long Int) ErrorObjBaseName (Text(50))
ErrorDescription (Text(255))
1 DontDoThat
Hey! Don't do that!
2 NotThatEither Woah!
Don't do that either!
3 AttemptedInstanceReinit
Attempted to reinitialize an instance of an object type that does not allow
multiple initializations per instance.
</tblXyzError>
<clsErrorDefinition>
Option Compare Database
Option Explicit
Private Const mycVBErrMethodNotApplicableInContxt = 444&
Private mlngErrNumber As Long
Private mstrErrDescrip As String
Public Property Get Number() As Long
Number = mlngErrNumber
End Property
Public Property Get Description() As String
Description = mstrErrDescrip
End Property
Public Sub Setup(ByVal lngErrNumber As Long, strDescription As String)
If mlngErrNumber <> 0 Then XyzErrAttemptedInstanceReinit.Raise
mlngErrNumber = lngErrNumber
mstrErrDescrip = strDescription
End Sub
Public Sub Raise()
Err.Raise Number, , Description
End Sub
</clsErrorDefinition>
<basXyzCodeGeneration>
Option Compare Database
Option Explicit
Private Const mycXyzErrDefModuleName = "basXyzErrorDefinitions"
Private Const mycXyzErrorTableName = "tblXyzError"
Private Const mycXyzObjPrefix = "xyz"
Public Const xyzcErrorCodeBase = 1000&
Public Sub GenerateXyzErrDefs()
Dim vbcsProject As VBIDE.VBComponents
Dim vbcModule As VBIDE.VBComponent
Dim db As DAO.Database
Dim rstXyzErrors As DAO.Recordset
Dim strNewFuncName As String
Dim lngErrorNum As Long
Set vbcsProject = VBE.VBProjects(1).VBComponents
RemoveVBComponentIfExists vbcsProject, mycXyzErrDefModuleName
Set vbcModule = CreateNewVBModule(vbcsProject, mycXyzErrDefModuleName)
vbcModule.Name = mycXyzErrDefModuleName
Set db = CurrentDb
Set rstXyzErrors = db.OpenRecordset( _
"SELECT * FROM [" & mycXyzErrorTableName & "] " & _
"ORDER BY ErrorCodeOffset", _
dbOpenDynaset, dbReadOnly)
If rstXyzErrors.RecordCount > 0 Then
While Not rstXyzErrors.EOF
strNewFuncName = _
UpperCaseFirstStringChar(mycXyzObjPrefix) & _
"Err" & rstXyzErrors!ErrorObjBaseName
lngErrorNum = xyzcErrorCodeBase + rstXyzErrors!ErrorCodeOffset
vbcModule.CodeModule.InsertLines _
vbcModule.CodeModule.CountOfLines + 1, _
"Public Function " & strNewFuncName & "() As clsErrorDefinition" & vbCrLf & _
" Static sobjErrDefinition As clsErrorDefinition" & vbCrLf & _
" If sobjErrDefinition Is Nothing Then" & vbCrLf & _
" Set sobjErrDefinition = New clsErrorDefinition" & vbCrLf & _
" sobjErrDefinition.Setup _" & vbCrLf & _
" " & lngErrorNum & ", _" & vbCrLf & _
" """ & rstXyzErrors!ErrorDescription & """" & vbCrLf & _
" End If" & vbCrLf & _
" Set " & strNewFuncName & " = sobjErrDefinition" & vbCrLf & _
"End Function"
rstXyzErrors.MoveNext
Wend
End If
rstXyzErrors.Close: Set rstXyzErrors = Nothing
Set db = Nothing
End Sub
Private Sub RemoveVBComponentIfExists( _
vbcs As VBIDE.VBComponents, _
strModuleName As String _
)
Dim vbcModule As VBIDE.VBComponent
On Error Resume Next
Set vbcModule = vbcs(strModuleName)
On Error GoTo 0
If Not (vbcModule Is Nothing) Then
vbcs.Remove vbcModule
Set vbcModule = Nothing
End If
End Sub
Private Function CreateNewVBModule( _
vbcs As VBIDE.VBComponents, _
strModuleName As String _
) As VBIDE.VBComponent
Dim vbcResultModule As VBIDE.VBComponent
Set vbcResultModule = vbcs.Add(vbext_ct_StdModule)
vbcResultModule.Name = strModuleName
Set CreateNewVBModule = vbcResultModule
End Function
</basXyzCodeGeneration>
Running GenerateXyzErrDefs generates the basXyzErrorDefinitions module as
follows...
<basXyzErrorDefinitions>
Option Compare Database
Option Explicit
Public Function XyzErrDontDoThat() As clsErrorDefinition
Static sobjErrDefinition As clsErrorDefinition
If sobjErrDefinition Is Nothing Then
Set sobjErrDefinition = New clsErrorDefinition
sobjErrDefinition.Setup _
1001, _
"Hey! Don't do that!"
End If
Set XyzErrDontDoThat = sobjErrDefinition
End Function
Public Function XyzErrNotThatEither() As clsErrorDefinition
Static sobjErrDefinition As clsErrorDefinition
If sobjErrDefinition Is Nothing Then
Set sobjErrDefinition = New clsErrorDefinition
sobjErrDefinition.Setup _
1002, _
"Woah! Don't do that either!"
End If
Set XyzErrNotThatEither = sobjErrDefinition
End Function
Public Function XyzErrAttemptedInstanceReinit() As clsErrorDefinition
Static sobjErrDefinition As clsErrorDefinition
If sobjErrDefinition Is Nothing Then
Set sobjErrDefinition = New clsErrorDefinition
sobjErrDefinition.Setup _
1003, _
"Attempted to reinitialize an instance of an object type that does
not allow multiple initializations per instance."
End If
Set XyzErrAttemptedInstanceReinit = sobjErrDefinition
End Function
</basXyzErrorDefinitions>