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(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 Continue() As Boolean
Continue = m_Continue
End Property
'缺省消息
Public Property Get DefaultMessage() As String
DefaultMessage = m_MessageString
End Property
Public Property Let DefaultMessage(ByVal MessageString As String)
m_MessageString = MessageString
End Property
'卸载窗口
Public Sub ExitForm(frm As Form)
If Not frm Is Nothing Then Unload frm
End Sub
'是否显示错误消息
Public Property Get DisplayDetailErrInfo() As Boolean
DisplayDetailErrInfo = m_DisplayDetailErrInfo
End Property
Public Property Let DisplayDetailErrInfo(ByVal Display As Boolean)
m_DisplayDetailErrInfo = Display
End Property
'合并消息
Private Function MergeMessage(Message As String) As String
MergeMessage = MergeString("消息:" & Message, vbCrLf, "编号:", Err.Number, vbCrLf, "说明:", Err.Description)
End Function
'合并字符串
Private 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()
Me.DefaultMessage = "数据产生冲突,请重新进入该功能."
Me.DisplayDetailErrInfo = False
End Sub
'退出整个系统
Public Sub ExitSystem()
MsgBox "产生致命错误,系统即将关闭.", vbCritical, "提示"
End
End Sub
Private m_Continue As Boolean
Private m_MessageString As String
Private m_DisplayDetailErrInfo As Boolean
Public Event onError()
'解析错误对象
'DefaultMessageString:显示的提示消息,如果为空则显示缺省消息
'frm:处理卸载窗体,可选
Public 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 Continue() As Boolean
Continue = m_Continue
End Property
'缺省消息
Public Property Get DefaultMessage() As String
DefaultMessage = m_MessageString
End Property
Public Property Let DefaultMessage(ByVal MessageString As String)
m_MessageString = MessageString
End Property
'卸载窗口
Public Sub ExitForm(frm As Form)
If Not frm Is Nothing Then Unload frm
End Sub
'是否显示错误消息
Public Property Get DisplayDetailErrInfo() As Boolean
DisplayDetailErrInfo = m_DisplayDetailErrInfo
End Property
Public Property Let DisplayDetailErrInfo(ByVal Display As Boolean)
m_DisplayDetailErrInfo = Display
End Property
'合并消息
Private Function MergeMessage(Message As String) As String
MergeMessage = MergeString("消息:" & Message, vbCrLf, "编号:", Err.Number, vbCrLf, "说明:", Err.Description)
End Function
'合并字符串
Private 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()
Me.DefaultMessage = "数据产生冲突,请重新进入该功能."
Me.DisplayDetailErrInfo = False
End Sub
'退出整个系统
Public Sub ExitSystem()
MsgBox "产生致命错误,系统即将关闭.", vbCritical, "提示"
End
End Sub
测试代码:
Dim WithEvents eh As ErrorHelper
Private 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()
Unload Me
End Sub
Private Sub Form_Load()
Set eh = New ErrorHelper
End Sub
Private 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()
Unload Me
End Sub
Private Sub Form_Load()
Set eh = New ErrorHelper
End Sub
通过这些代码可以节约一些重复代码的数量,作为一个小的底层错误处理机制应该还可以.