在VB中使用自定义·异常处理·过滤函数避免开发环境崩溃（源代码）

Question

'---------------- mduExceptionHandler.bas ---------------
Option ExplicitPublic Declare Function SetUnhandledExceptionFilter Lib "kernel32" (ByVal lpTopLevelExceptionFilter As Long) As LongPublic 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 TypePublic 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 SubPublic 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 FunctionPrivate 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

Answer 1

使用方法：
将上面代码放于模块文件之中，需要用的时候将模块文件加到工程中。
然后在窗体Form_Load或其他过程中写入
Call InitExceptionHandler
总之要保证这句是程序的第1句。使用实例：
'------------ Form1.frm -------------
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Private Sub Form_Load()
    On Error GoTo Error_Handler
    Call InitExceptionHandler
    CopyMemory ByVal 0, ByVal 123, 100
    Exit Sub
Error_Handler:
    Resume Next
End Sub

Answer 2

现在各位在调试API的时候，基本上不用提心吊胆，老是担心IDE什么时候耍性子了

Answer 3

酷，收藏先。调用示例如下：
Option ExplicitPrivate Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Private Sub Form_Load()
    On Error GoTo errFinish
    InitExceptionHandler
    CopyMemory ByVal 1, ByVal VarPtr(100), 3
    Exit Sub
errFinish:
    MsgBox Err.Description
End Sub
记得很久以前看过一个老外写的处理gpf的例子，只是当时没有收藏起来，等到失去时才知道后悔莫急，如果上天再给我一个机会……

Answer 4

适才见一仁兄问及SEH的事情，我才想起把自己常用的东西贴上来，抢了你第一步，真是惭愧惭愧啊

Answer 5

感觉我以前写的那个处理SEH的代码和这个差不多，不过就是不成功，明天去公司再好好看看，已经汇了100分到你的帐户。

Answer 6

呵呵，谢谢
估计不成功的原因很有可能是用了VB API浏览器里粘贴过来的代码的关系，那里面经常会有一些错误程序翻译的东西虽然快但就是死板了一点

Answer 7

我是按msdn里说的方法一步一步试的，可能是第一个 copymemory 的第一个参数没加 varptr吧，我那个程序在调试时如果出现内存只读的话程序会关闭，但是VB不会关闭，不过编译成可执行文件后会出现内存只读的现象，我也搞不懂问题出现在哪。

Answer 8

今天真倒霉，刚来公司时老总说如果要刻什么东西都要经过它批准的，结果今天刚拿了一个刻录盘准备去刻就被它盯上了，刻录机的线被它拨过好几次，要是这次它把刻录机摘了的话那我写的程序就没法弄回来了，现在穷得连U盘都没不起，倒。再加一个问题，帮忙看看。http://expert.csdn.net/Expert/topic/2859/2859538.xml?temp=.8118708

Answer 9

//这段代码可以用吗？
呵呵，恐怕搭不上。下面是你要的函数：'使用方法：sOut=ContinuousSpacesKiller(sIn,True)
'参数说明：sIn - 输入字符串
'          fTrimFirst - 先去除sIn两端所有空格
Public Function ContinuousSpacesKiller(ByVal sIn As String, Optional fTrimFirst As Boolean = True) As String
    Dim s As String, sCrt As String, fSpace As Boolean
    Dim i As Long
    s = IIf(fTrimFirst, Trim$(sIn), sIn)
    sCrt = ""
    fSpace = False
    ContinuousSpacesKiller = ""
    For i = 1 To Len(s)
        sCrt = Mid$(s, i, 1)
        ContinuousSpacesKiller = ContinuousSpacesKiller & IIf(fSpace And (sCrt = " "), "", sCrt)
        fSpace = (sCrt = " ")
    Next
End Function

Answer 10

再添加一段到mduExceptionHandler.basPrivate Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As LongPrivate Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF'********************************************************************************
'用途：返回调用Windows API后系统返回的错误描述或者将要查询的错误号转换成错误描述
'
'使用方法:
'        1. sDes=GetLastDllErrDescription()
'        2. sDes=GetLastDllErrDescription(要查询的错误号)
'********************************************************************************
Public Function GetLastDllErrDescription(Optional vErrNumber As Variant = Empty) As String
    Dim lErrNumber As Long
    
    lErrNumber = Err.LastDllError
    
    If Not IsEmpty(vErrNumber) Then
        If IsNumeric(vErrNumber) Then
            lErrNumber = CLng(vErrNumber)
        End If
    End If
    
    Dim sDesc As String * 512, lLen As Long
    lLen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM + FORMAT_MESSAGE_IGNORE_INSERTS, ByVal 0&, lErrNumber, 0&, sDesc, Len(sDesc), ByVal 0&)
    GetLastDllErrDescription = Left$(sDesc, lLen)
End Function