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

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