I have a beauty that Randall wrote.
1) Post the code in a new module (I call mine ErrorControl)
2) Add a reference to MICROSOFT visual Basic for Applications Extensibility 5.3
3) Whenever you want error control in a sub or function just make the sub active then goto to tools (the same tools pull down as holds References) -> Macros modulename.AutoErrorHandler
"Run" this and the error handler will be automajically written.
Option Explicit
Dim objIDE As VBE
Dim objPane As CodePane
Dim objMod As CodeModule
'Randall Rath
Public Sub AutoErrorHandler()
Dim strProc As String
Dim lngFirst As Long
Dim lngTotal As Long
Dim lngLast As Long
On Error GoTo Err_Control
Set objIDE = Application.VBE
Set objPane = objIDE.ActiveCodePane
Set objMod = objPane.CodeModule
strProc = GetCurrentProc
lngFirst = objMod.ProcBodyLine(strProc, _
vbext_pk_Proc)
lngTotal = objMod.ProcCountLines(strProc, _
vbext_pk_Proc)
lngLast = lngFirst + lngTotal
Call InsertGoto(lngLast, lngFirst)
Call InsertHandler(lngLast, lngFirst)
Set objIDE = Nothing
Set objPane = Nothing
Set objMod = Nothing
Exit_Here:
Exit Sub
Err_Control:
Select Case Err.Number
Case Else
MsgBox Err.Description
Resume Exit_Here
End Select
End Sub
Private Function GetCurrentProc() As String
Dim lngSC As Long 'Start column
Dim lngEC As Long 'End Column
Dim lngSL As Long 'Start Line
Dim lngEL As Long 'End Line
On Error GoTo Err_Control
objPane.GetSelection lngSL, lngSC, _
lngEL, lngEC
'Debug.Print lngSL, lngEL
GetCurrentProc = objMod.ProcOfLine(lngSL, _
vbext_pk_Proc)
Exit_Here:
Exit Function
Err_Control:
Select Case Err.Number
'Add your Case selections here
Case Else
MsgBox Err.Description
Resume Exit_Here
End Select
End Function
Private Sub InsertGoto(LastLine As Long, _
FirstLine As Long)
Dim lngCnt As Long
Dim strLine As String
On Error GoTo Err_Control
FirstLine = FirstLine + 1
For lngCnt = FirstLine To LastLine
If Not Right(objMod.Lines(lngCnt - 1, 1), _
1) = "_" Then
strLine = objMod.Lines(lngCnt, 1)
If InStr(1, strLine, "Dim", _
vbTextCompare) = 0 Then
objMod.InsertLines lngCnt, _
vbTab & "On Error GoTo Err_Control"
Exit For
End If
End If
Next lngCnt
Exit_Here:
Exit Sub
Err_Control:
Select Case Err.Number
'Add your Case selections here
Case Else
MsgBox Err.Description
Resume Exit_Here
End Select
End Sub
Private Sub InsertHandler(LastLine As Long, FirstLine As Long)
Dim lngCnt As Long
Dim strLine As String
On Error GoTo Err_Control
For lngCnt = LastLine To FirstLine Step -1
strLine = objMod.Lines(lngCnt, 1)
Select Case strLine
Case "End Sub"
objMod.InsertLines lngCnt, "Exit_Here:"
objMod.InsertLines lngCnt + 1, vbTab & _
"Exit Sub"
objMod.InsertLines lngCnt + 2, _
"Err_Control:"
objMod.InsertLines lngCnt + 3, vbTab & _
"Select Case Err.Number"
objMod.InsertLines lngCnt + 4, vbTab & _
"'Add your Case selections here"
objMod.InsertLines lngCnt + 5, vbTab & _
vbTab & "Case Else"
objMod.InsertLines lngCnt + 6, vbTab & _
vbTab & "MsgBox Err.Description"
objMod.InsertLines lngCnt + 7, vbTab & _
vbTab & "Err.Clear"
objMod.InsertLines lngCnt + 8, vbTab & _
vbTab & "Resume Exit_Here"
objMod.InsertLines lngCnt + 9, vbTab & _
"End Select"
Exit For
Case "End Function"
objMod.InsertLines lngCnt, "Exit_Here:"
objMod.InsertLines lngCnt + 1, vbTab & _
"Exit Function"
objMod.InsertLines lngCnt + 2, _
"Err_Control:"
objMod.InsertLines lngCnt + 3, vbTab & _
"Select Case Err.Number"
objMod.InsertLines lngCnt + 4, vbTab & _
"'Add your Case selections here"
objMod.InsertLines lngCnt + 5, vbTab & _
vbTab & "Case Else"
objMod.InsertLines lngCnt + 6, vbTab & _
vbTab & "MsgBox Err.Description"
objMod.InsertLines lngCnt + 7, vbTab & _
vbTab & "Err.Clear"
objMod.InsertLines lngCnt + 8, vbTab & _
vbTab & "Resume Exit_Here"
objMod.InsertLines lngCnt + 9, vbTab & _
"End Select"
Exit For
End Select
Next lngCnt
Exit_Here:
Exit Sub
Err_Control:
Select Case Err.Number
Case Else
MsgBox Err.Description
Debug.Print Err.Number & Space(2) & Err.Description
Resume Exit_Here
End Select
End Sub
Here is an example
Sub Test()
On Error GoTo Err_Control
Exit_Here:
Exit Sub
Err_Control:
Select Case Err.Number
'Add your Case selections here
Case Else
MsgBox Err.Description
Err.Clear
Resume Exit_Here
End Select
End Sub