mdlexceptionhandler.bas

本系统可用于医院和专业体检中心的健康体检管理

Attribute VB_Name = "mdlExceptionHandler"
'在VB中使用自定义·异常处理·过滤函数避免开发环境崩溃（源代码）
'使用方法:
'将下面代码放于模块文件之中，需要用的时候将模块文件加到工程中。
'然后在窗体Form_Load或其他过程中写入
'Call InitExceptionHandler
'总之要保证这句是程序的第1句
'---------------- mduExceptionHandler.bas ---------------
Option Explicit

Public Declare Function SetUnhandledExceptionFilter Lib "kernel32" (ByVal lpTopLevelExceptionFilter As Long) As Long

Public Const EXCEPTION_MAXIMUM_PARAMETERS = 15&

Public Type EXCEPTION_RECORD
    ExceptionCode As Long
    ExceptionFlags As Long
    pExceptionRecord As Long
    ExceptionAddress As Long
    NumberParameters As Long
    ExceptionInformation(EXCEPTION_MAXIMUM_PARAMETERS - 1) As Long
End Type

Public Type EXCEPTION_POINTERS
    pExceptionRecord As Long
    ContextRecord As Long
End Type

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Sub InitExceptionHandler()
    SetUnhandledExceptionFilter AddressOf MyExceptionFilter
End Sub

Public Function MyExceptionFilter(lpExceptionPointers As EXCEPTION_POINTERS) As Long
    Dim i As Long
    Dim utExceptionRecord As EXCEPTION_RECORD
    Dim sErrMsg As String

    CopyMemory ByVal VarPtr(utExceptionRecord), ByVal lpExceptionPointers.pExceptionRecord, Len(utExceptionRecord)
    Do
        i = i + 1
        If i > 100 Then Exit Do '如果错误嵌套超过100层就拜拜跳出
        With utExceptionRecord
            sErrMsg = TranslateExceptionCode(.ExceptionCode)
            
            If sErrMsg = TranslateExceptionCode(&HC0000005) Then
                sErrMsg = sErrMsg & " - 位于 &H" & Hex(.ExceptionAddress) & " 的代码试图向地址 &H" & _
                            Hex(.ExceptionInformation(1)) & " " & _
                            IIf(.ExceptionInformation(0) = 0, "读取", "写入") & "数据"
            End If
            
            If .pExceptionRecord = 0 Then Exit Do
            
            CopyMemory ByVal VarPtr(utExceptionRecord), ByVal .pExceptionRecord, Len(utExceptionRecord)
            
        End With
        sErrMsg = sErrMsg & vbCrLf
    Loop
    
    Err.Raise vbObjectError + &H123, "运行时异常", sErrMsg
End Function

Private Function TranslateExceptionCode(ByVal lExceptionCode As Long) As String
    Select Case lExceptionCode
    Case &HC0000005
        TranslateExceptionCode = "EXCEPTION_ACCESS_VIOLATION"
    Case &HC000008C
        TranslateExceptionCode = "EXCEPTION_ARRAY_BOUNDS_EXCEEDEDEX"
    Case &H80000003
        TranslateExceptionCode = "EXCEPTION_BREAKPOINT"
    Case &H80000002
        TranslateExceptionCode = "EXCEPTION_DATATYPE_MISALIGNMENT"
    Case &HC000008D
        TranslateExceptionCode = "EXCEPTION_FLOAT_DENORMAL_OPERANDEXCE"
    Case &HC000008E
        TranslateExceptionCode = "EXCEPTION_FLOAT_DIVIDE_BY_ZERO"
    Case &HC000008F
        TranslateExceptionCode = "EXCEPTION_FLOAT_INEXACT_RESULT"
    Case &HC0000090
        TranslateExceptionCode = "EXCEPTION_INVALID_OPERATION"
    Case &HC0000091
        TranslateExceptionCode = "EXCEPTION_FLOAT_OVERFLOW"
    Case &HC0000092
        TranslateExceptionCode = "EXCEPTION_FLOAT_STACK_CHECK"
    Case &HC0000093
        TranslateExceptionCode = "EXCEPTION_FLOAT_UNDERFLOW"
    Case &H80000001
        TranslateExceptionCode = "EXCEPTION_GUARD_PAGE_VIOLATION"
    Case &HC000001D
        TranslateExceptionCode = "EXCEPTION_ILLEGAL_INSTRUCTION"
    Case &HC0000006
        TranslateExceptionCode = "EXCEPTION_IN_PAGE_ERROR"
    Case &HC0000094
        TranslateExceptionCode = "EXCEPTION_INT_DIVIDE_BY_ZERO"
    Case &HC0000095
        TranslateExceptionCode = "EXCEPTION_INT_OVERFLOW"
    Case &HC0000026
        TranslateExceptionCode = "EXCEPTION_INVALID_DISPOSITION"
    Case &HC0000008
        TranslateExceptionCode = "EXCEPTION_INVALID_HANDLE"
    Case &HC0000025
        TranslateExceptionCode = "EXCEPTION_NONCONTINUABLE_EXCEPTION"
    Case &HC0000096
        TranslateExceptionCode = "EXCEPTION_PRIVILEGED_INSTRUCTION"
    Case &HC0000004
        TranslateExceptionCode = "EXCEPTION_SINGLE_STEP"
    Case &HC00000FD
        TranslateExceptionCode = "EXCEPTION_STACK_OVERFLOW"
    Case Else
        TranslateExceptionCode = "EXCEPTION_UNKOWN_CODE"
    End Select
End Function