errors.bas

金算盘软件代码

Attribute VB_Name = "Errors"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  错误处理中心
'  作者：魏 然
'  日期：1998.05.12
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit

'文件错误号
Const mnErrBadFileName = 64
Const mnErrBadFileNameOrNumber = 52
Const mnErrPathDoesNotExist = 76
Const mnErrBadFileMode = 54
Const mnErrFileAlreadyOpen = 55
Const mnErrInputPastEndOfFile = 62
Const mnErrFileNotFound = 3024
'磁盘错误号
Const mnErrDeviceUnavailable = 68
Const mnErrDiskNotReady = 71
Const mnErrDeviceIO = 57
Const mnErrDiskFull = 61
'打印机错误号
Const mnErrPrnCanNotSet = 396         '在同一页内不能对同一属性设置不同值
Const mnErrPrn = 482                  '打印机错误
Const mnErrPrnNotSupport = 483        '打印机驱动程序不支持该属性
Const mnErrPrnDeviceUnavailable = 484 '打印机驱动程序无效
'Dao 错误
Const mnErrCanotOpenMoreTable = 3014
Const mnErrMoreCrossColumn = 3205     '交叉数据表的列标题 <value > 太多
Const mnErrDataChangedByOther = 3197
Const mnErrDataLocked = 3260

'其他错误号
Const mnOutofMemory = 7


'错误处理返回值
Public Enum ErrDealType
    edtResume = 0        '恢复
    edtResumeNext = 1    '恢复下一条语句
    edtCanNotResume = 2  '无法恢复的错误
    edtCanNotKnown = 3   '无法识别的错误
End Enum

Function ErrorsDeal(Optional ByVal ControlAuth As Boolean = False, Optional objControled As Object = Nothing, Optional ErrNum As Long) As ErrDealType
    Dim intMsgType As Integer
    Dim strMsg As String
    Dim intResponse As Integer
    Dim intLockCount As Integer
    Dim intRndCount As Integer
    Dim blnRepare As Boolean
    Dim i As Integer
    
    blnRepare = False
    intMsgType = vbExclamation
    
    ErrNum = Err.Number
    
    Select Case Err.Number
        Case mnOutofMemory
            strMsg = "您打开的窗体太多,请关闭一些窗体!"
            intMsgType = vbExclamation + vbOKOnly
        Case mnErrDeviceUnavailable         ' 错误 68
            strMsg = "设备不可用"
            intMsgType = vbExclamation + vbOKCancel
        Case mnErrDiskNotReady              ' 错误 71
            strMsg = "在驱动器中插入一张软盘并关好驱动器小门"
            intMsgType = vbExclamation + vbOKCancel
        Case mnErrDeviceIO                  ' 错误 57
            strMsg = "内部磁盘错误"
            intMsgType = vbExclamation + vbOKOnly
        Case mnErrDiskFull                  ' 错误 61
            strMsg = "磁盘已满，继续吗？"
            intMsgType = vbExclamation + vbAbortRetryIgnore
        Case mnErrBadFileName, mnErrBadFileNameOrNumber ' 错误 64 & 52
            strMsg = "文件名非法"
            intMsgType = vbExclamation + vbOKCancel
        Case mnErrPathDoesNotExist          ' 错误 76
            strMsg = "路径不存在"
            intMsgType = vbExclamation + vbOKCancel
        Case mnErrBadFileMode               ' 错误 54
            strMsg = "不能以此类访问打开文件"
        Case mnErrFileAlreadyOpen           ' 错误 55
            strMsg = "文件已经被打开"
            intMsgType = vbExclamation + vbOKCancel
        Case mnErrInputPastEndOfFile        ' 错误 62
            strMsg = "文件有一个不标准的文件结束标志，"
            strMsg = strMsg & "或企图读文件结束标志之后"
            strMsg = strMsg & "的内容"
            intMsgType = vbExclamation + vbAbortRetryIgnore
        Case 3049
            strMsg = "打开帐套失败，是否自动修复数据?"
            intMsgType = vbExclamation + vbOKCancel
            blnRepare = True
        Case mnErrDataChangedByOther         '记录集中的数据在被打开之后发生了变更。
            strMsg = "有其他用户在你以前修改了数据,覆盖吗?"
            intMsgType = vbExclamation + vbYesNo

        Case mnErrDataLocked                 ' 记录被锁定。
            strMsg = "数据被其他用户锁定,现在不能修改!"
            intMsgType = vbExclamation + vbAbortRetryIgnore
        Case mnErrCanotOpenMoreTable
            strMsg = "打开窗体太多，请先关闭一些窗体!"
            intMsgType = vbExclamation + vbOKOnly
        Case Else
            ErrorsDeal = edtCanNotKnown
            Exit Function
    End Select
    intResponse = MsgBox(strMsg, intMsgType, App.title)
    Select Case intResponse
        Case vbYes, vbRetry                  '确定, 重试 按钮
            If blnRepare Then                '修复数据库
                '?DBEngine.RepairDatabase (gclsBase.BaseFile)
            End If
            ErrorsDeal = edtResume
        Case vbCancel, vbIgnore              ' 取消, 忽略 按钮
            ErrorsDeal = edtResumeNext
        Case vbAbort                         ' 中止 按钮
            ErrorsDeal = edtCanNotResume
            If ControlAuth And (Not objControled Is Nothing) Then
                 Unload objControled
            End If
        Case Else
            ErrorsDeal = edtCanNotKnown
            If ControlAuth And (Not objControled Is Nothing) Then
                 Unload objControled
            End If
    End Select
End Function