VB6中的ErrorHelper

今天还是修改原先VB6处理的程序,在错误处理方面需要一些改进,弄了一个ErrorHelper的类,还是有点用处的,存到这里吧.

Option   Explicit

Private  m_Continue  As   Boolean

Private  m_MessageString  As   String

Private  m_DisplayDetailErrInfo  As   Boolean

Public   Event  onError()

' 解析错误对象
' DefaultMessageString:显示的提示消息,如果为空则显示缺省消息
' frm:处理卸载窗体,可选
Public   Function Parse() Function Parse(Optional DefaultMessageString As String, Optional frm As Form)
    Select Case Err.Number
        Case 0
            m_Continue = False
        Case Else
            If IsMissing(DefaultMessageString) Or Len(DefaultMessageString) = 0 Then
                If m_DisplayDetailErrInfo Then
                    MsgBox MergeMessage(DefaultMessage), vbCritical, "提示"
                Else
                    MsgBox DefaultMessage, vbCritical, "提示"
                End If
            Else
                If m_DisplayDetailErrInfo Then
                    MsgBox MergeMessage(DefaultMessageString), vbCritical, "提示"
                Else
                    MsgBox DefaultMessageString, vbCritical, "提示"
                End If
            End If
            If Not IsMissing(frm) Then
                ExitForm frm
            End If
            m_Continue = True
            RaiseEvent onError
    End Select
    Err.Clear
End Function

' 处理完错误后是否进行其他处理
Public   Property Get() Property Get Continue() As Boolean
    Continue = m_Continue
End Property

' 缺省消息
Public   Property Get() Property Get DefaultMessage() As String
    DefaultMessage = m_MessageString
End Property

Public   Property Let() Property Let DefaultMessage(ByVal MessageString As String)
    m_MessageString = MessageString
End Property

' 卸载窗口
Public   Sub ExitForm() Sub ExitForm(frm As Form)
    If Not frm Is Nothing Then Unload frm
End Sub

' 是否显示错误消息
Public   Property Get() Property Get DisplayDetailErrInfo() As Boolean
    DisplayDetailErrInfo = m_DisplayDetailErrInfo
End Property

Public   Property Let() Property Let DisplayDetailErrInfo(ByVal Display As Boolean)
    m_DisplayDetailErrInfo = Display
End Property

' 合并消息
Private   Function MergeMessage() Function MergeMessage(Message As String) As String
    MergeMessage = MergeString("消息:" & Message, vbCrLf, "编号:", Err.Number, vbCrLf, "说明:", Err.Description)
End Function

' 合并字符串
Private   Function MergeString() Function MergeString(ParamArray arg()) As String
    Dim i As Integer
    For i = 0 To UBound(arg())
        MergeString = MergeString & arg(i)
    Next
End Function

Private   Sub Class_Initialize() Sub Class_Initialize()
    Me.DefaultMessage = "数据产生冲突,请重新进入该功能."
    Me.DisplayDetailErrInfo = False
End Sub

' 退出整个系统
Public   Sub ExitSystem() Sub ExitSystem()
    MsgBox "产生致命错误,系统即将关闭.", vbCritical, "提示"
    End
End Sub

测试代码:

Dim   WithEvents  eh  As  ErrorHelper

Private   Sub Command1_Click() Sub Command1_Click()
#If ErrorOnOff = 0 Then
    On Error GoTo onErrors
#End If
    Err.Raise 100
    MsgBox "OK"
onErrors:
    eh.Parse
    'If eh.Continue Then eh.ExitSystem
    'If eh.Continue Then Resume Next
End Sub

Private   Sub eh_onError() Sub eh_onError()
    Unload Me
End Sub

Private   Sub Form_Load() Sub Form_Load()
    Set eh = New ErrorHelper
End Sub

通过这些代码可以节约一些重复代码的数量,作为一个小的底层错误处理机制应该还可以.