使用Acad处理礼仪时出错

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

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