实用代码（兼散分）：VBErrCatcher类——VB*全局*错误捕获 之 研究

1.VBErrCatcher.cls 第1部分
'------------------------------ 类模块 VBErrCatcher.cls ------------------------------
Option Explicit
'本模块名称
Private Const THIS_MODULE_NAME As String = "CVBErrCatcher"Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function VirtualAlloc Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function VirtualProtectEx Lib "kernel32" (ByVal hProcess As Long, lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Function VirtualQueryEx Lib "kernel32" (ByVal hProcess As Long, lpAddress As Any, lpBuffer As MEMORY_BASIC_INFORMATION, ByVal dwLength As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As LongPrivate Type MEMORY_BASIC_INFORMATION
     BaseAddress As Long
     AllocationBase As Long
     AllocationProtect As Long
     RegionSize As Long
     State As Long
     Protect As Long
     lType As Long
End TypePrivate Const PROCESS_ALL_ACCESS = &H1F0FFFPrivate Const PAGE_READWRITE As Long = &H4
Private Const MEM_COMMIT As Long = &H1000
Private Const MEM_DECOMMIT As Long = &H4000
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
Private Enum VBEC_ENUM_WHEREAMI
    evaDev = 0
    evaNative
    evaPCode
End EnumPrivate m_oAnyCall As CVBAnyCall
Private m_fIsPCode As Boolean
Private m_lEHAddress As Long
Private m_lWhereAmI As VBEC_ENUM_WHEREAMI
Private m_lhModVBA6 As Long
Private m_lhModMSVBVM As Long
Private m_bOriEHBytes(5) As Byte
Private m_lCodeBufferAddress As Long
Private m_lCodeStartAddress As Long
Private m_lJumpAddress As Long
Private m_fIsInstalled As BooleanPrivate Const CODE_BUFFER_SIZE As Long = 512'******************************* 暴露的接口 *******************************
'安装自定义错误处理过程
'lMyEHAddress:自定义错误处理过程地址
Public Function InstallEH(ByVal lMyEHAddress As Long) As Boolean
        
    If m_lWhereAmI = evaNative Then
        
        Call ReadWriteMemory(m_lEHAddress, m_bOriEHBytes())
        
        m_lCodeStartAddress = PrepareCode(lMyEHAddress)
        
        If m_lCodeStartAddress = 0 Then Exit Function
        
        m_lJumpAddress = VarPtr(m_lCodeStartAddress)        CopyMemory m_bOriEHBytes(2), m_lJumpAddress, 4        m_bOriEHBytes(0) = &HFF
        m_bOriEHBytes(1) = &H25
        
        If ReadWriteMemory(m_lEHAddress, m_bOriEHBytes(), False) Then     '写入我们的地址
            InstallEH = True
            m_fIsInstalled = True
        End If
    End If
End Function'卸载自定义错误处理过程
Public Function UninstallEH() As Boolean
    If Not m_fIsInstalled Then Exit Function
    
    If m_lWhereAmI = evaNative Then
        If ReadWriteMemory(m_lEHAddress, m_bOriEHBytes(), False) Then    '恢复原来的地址
            If MemOp(False) Then
                UninstallEH = True
            End If
        End If
    End If
End Function'是否已安装自定义错误处理过程
Public Property Get IsInstalled() As Boolean
    IsInstalled = m_fIsInstalled
End Property'当前程序的编译方式以及运行环境
'取参考枚举变量 VBEC_ENUM_WHEREAMI
Public Property Get WhereAmI() As Long
    WhereAmI = m_lWhereAmI
End Property'当前程序是否为P代码方式编译
Public Property Get IsPCode() As Boolean
    IsPCode = m_fIsPCode
End Property'VB的错误处理程序地址
Public Property Get EHAddress() As Long
    EHAddress = m_lEHAddress
End Property'******************************* 暴露的接口 *******************************

解决方案 »

  1.   

    2.VBErrCatcher.cls 第2部分'******************************** 私有函数 ********************************
    Private Property Let EHAddress(ByVal lAddr As Long)
        m_lEHAddress = lAddr
        
        If (m_lhModVBA6 <> 0 And m_lEHAddress >= m_lhModVBA6) Then
            m_lWhereAmI = evaDev
            Exit Property
        End If
        
        If (m_lhModMSVBVM <> 0 And m_lEHAddress >= m_lhModMSVBVM) Then
            m_lWhereAmI = evaPCode
            m_fIsPCode = True
            Exit Property
        End If
       
        m_lWhereAmI = evaNative
    End PropertyPrivate Function GetEHAddress() As Long
        Dim sByteCode As String
        
        '64 A1 00 00 00 00 mov eax,fs:[00000000]
        sByteCode = "64 A1 00 00 00 00 "
        '8B 40 04          mov eax,dword ptr [eax+4]
        sByteCode = sByteCode & "8B 40 04 "
        'C3                ret
        sByteCode = sByteCode & "C3"
        
        GetEHAddress = m_oAnyCall.CallCodeBytes(sByteCode)
        EHAddress = GetEHAddress
    End FunctionPrivate Function GetByteString(b() As Byte, Optional fPrint As Boolean = False) As String
        Dim lLen As Long
        lLen = UBound(b) - LBound(b) + 1
        If lLen <= 0 Or Err.Number <> 0 Then
            Exit Function
        End If
        
        Dim i As Long
        For i = 0 To lLen - 1
            If b(i) < 16 Then
                GetByteString = GetByteString & "0" & Hex(b(i))
            Else
                GetByteString = GetByteString & Hex(b(i))
            End If
            GetByteString = GetByteString & " "
        Next
        
        If fPrint Then
            Debug.Print GetByteString
        End If
    End FunctionPrivate Function ReadWriteMemory(ByVal lAddr As Long, buff() As Byte, Optional fRead As Boolean = True) As Boolean
        Dim hProcess As Long
        Dim mi As MEMORY_BASIC_INFORMATION
        Dim lpAddress As Long, lOldProtect As Long
        Dim lBytesReadWrite As Long
        Dim bTmp() As Byte
        
        lpAddress = lAddr
        hProcess = OpenProcess(PROCESS_ALL_ACCESS, 0&, GetCurrentProcessId)
        If hProcess Then
            If VirtualQueryEx(hProcess, ByVal lpAddress, mi, Len(mi)) Then
                If VirtualProtectEx(hProcess, ByVal mi.BaseAddress, mi.RegionSize, PAGE_READWRITE, lOldProtect) <> 0 Then
                    If fRead Then
                        ReadProcessMemory hProcess, ByVal lpAddress, buff(0), UBound(buff) + 1, lBytesReadWrite
                    Else
                        ReDim bTmp(UBound(buff))
                        ReadProcessMemory hProcess, ByVal lpAddress, bTmp(0), UBound(bTmp) + 1, lBytesReadWrite
                        WriteProcessMemory hProcess, ByVal lpAddress, buff(0), UBound(buff) + 1, lBytesReadWrite
                        CopyMemory buff(0), bTmp(0), UBound(bTmp) + 1
                    End If
                    Call VirtualProtectEx(hProcess, ByVal mi.BaseAddress, mi.RegionSize, lOldProtect, lOldProtect)
                    ReadWriteMemory = (lBytesReadWrite <> 0)
                End If
            End If
            CloseHandle hProcess
        End If
    End FunctionPrivate Function PrepareCode(ByVal lMyEHAddress As Long) As Long
        If Not MemOp() Then Exit Function    Dim lCodeStartPosition As Long, lLastPos As Long
        Dim bCodeBytes(CODE_BUFFER_SIZE - 1) As Byte
        Dim i As Long
            
        lCodeStartPosition = GetAlignedlCodeStartPosition(m_lCodeBufferAddress)
        lLastPos = lCodeStartPosition - m_lCodeBufferAddress
        
        For i = 0 To lLastPos - 1
            bCodeBytes(i) = &HCC
        Next
           
        'call lMyEHAddress
        AddByteToCode &HE8, bCodeBytes(), lLastPos
        AddLongToCode lMyEHAddress - (m_lCodeBufferAddress + VarPtr(bCodeBytes(lLastPos)) - VarPtr(bCodeBytes(0))) - 4, bCodeBytes(), lLastPos
        
        'jmp m_lOriEHAddressVBA
        CopyMemory bCodeBytes(lLastPos), m_bOriEHBytes(0), UBound(m_bOriEHBytes) + 1
        lLastPos = lLastPos + UBound(m_bOriEHBytes) + 1
        
        
        For i = lLastPos To CODE_BUFFER_SIZE - 1
            bCodeBytes(i) = &HCC
        Next
           
        CopyMemory ByVal m_lCodeBufferAddress, bCodeBytes(0), CODE_BUFFER_SIZE
        
        PrepareCode = lCodeStartPosition
    End FunctionPrivate Function AddByteToCode(ByVal bCode As Byte, bCodeBytes() As Byte, lPos As Long) As Long
        bCodeBytes(lPos) = bCode
        lPos = lPos + 1
    End FunctionPrivate Function AddLongToCode(ByVal lCode As Long, bCodeBytes() As Byte, lPos As Long) As Long
        CopyMemory bCodeBytes(lPos), lCode, 4
        lPos = lPos + 4
    End FunctionPrivate Function GetAlignedlCodeStartPosition(lAddr As Long) As Long
        GetAlignedlCodeStartPosition = lAddr + (15 - (lAddr - 1) Mod 16)
        If (15 - (lAddr - 1) Mod 16) = 0 Then GetAlignedlCodeStartPosition = GetAlignedlCodeStartPosition + 16
    End FunctionPrivate Function MemOp(Optional fAllocate As Boolean = True) As Boolean
        If fAllocate Then
            m_lCodeBufferAddress = VirtualAlloc(ByVal 0&, CODE_BUFFER_SIZE, MEM_COMMIT, PAGE_READWRITE)
            MemOp = (m_lCodeBufferAddress <> 0)
        Else
            MemOp = (VirtualFree(ByVal m_lCodeBufferAddress, CODE_BUFFER_SIZE, MEM_DECOMMIT) <> 0)
        End If
    End FunctionPrivate Sub Class_Initialize()
        m_lhModVBA6 = GetModuleHandle("vba6.dll")
        m_lhModMSVBVM = GetModuleHandle("msvbvm60.dll")
        If m_lhModMSVBVM = 0 Then
            m_lhModMSVBVM = GetModuleHandle("msvbvm50.dll")
        End If
        
        Set m_oAnyCall = New CVBAnyCall
        With m_oAnyCall
            .IsStandardCall = False
            .ThroughVTable = True
        End With
        Call GetEHAddress
    End SubPrivate Sub Class_Terminate()
        Set m_oAnyCall = Nothing
    End Sub
    '******************************** 私有函数 ********************************
      

  2.   

    使用例子：'------------------------------ 窗体模块 Form2.frm ------------------------------
    Option Explicit
    '本模块名称
    Private Const THIS_MODULE_NAME As String = "Form2"Private WithEvents cmd As CommandButtonPrivate Sub cmd_Click()
        '一定要加上on error resume next这句,否则程序便会中止
        On Error Resume Next
        MsgBox "就要发生错误了"
        MsgBox 1 / 0
        MsgBox "这是下一句"
    End SubPrivate Sub Form_Initialize()
        '使用SEH，防止程序崩溃
        Call InitExceptionHandler
    End SubPrivate Sub Form_Load()
        '添加按钮
        Set cmd = Me.Controls.Add("VB.CommandButton", "Command1")
        With cmd
            .Default = True
            .Caption = "运行例子"
            .Move 1520, 1170
            .Visible = True
        End With
        
        MsgBox "VB的错误处理代码地址为:&H" & Hex(g_oErrCather.EHAddress)
        
        '附加上我们自己的错误处理程序
        If g_oErrCather.InstallEH(AddressOf MyEH) Then
            MsgBox "错误处理程序安装成功!"
        End If
        
        MsgBox "当前程序是否为P代码:" & IIf(g_oErrCather.IsPCode, "是", "不是")
        
        Select Case g_oErrCather.WhereAmI
        Case 0 '开发环境
            MsgBox "我还在开发中……"
        Case 1 'Native编译
            MsgBox "我的编译模式为本地代码模式……"
        Case 2 'PCode编译
            MsgBox "我的编译模式为P代码模式……"
        Case Else
            MsgBox "有问题了……"
        End Select
    End SubPrivate Sub Form_Unload(Cancel As Integer)
        If g_oErrCather.IsInstalled Then
            '卸载错误处理程序
            g_oErrCather.UninstallEH
        End If
    End Sub'------------------------------ 模块 Module1.bas ------------------------------
    Option Explicit
    '本模块名称
    Private Const THIS_MODULE_NAME As String = "Module1"Public g_oErrCather As New CVBErrCatcherPublic Function MyEH() As Long
        MsgBox "有错误发生!错误描述为:" & Err.Description, , "自定义错误处理函数"
    End Function
      

  3.   

    测试方法：
    1、新建一个工程
    2、新建一个私有类命名为 CVBErrCatcher
    3、新建一个私有类命名为 CVBAnyCall
    4、新建一个模块 Module1
    5、将各自的代码贴入CVBAnyCall的代码请参考 
    http://expert.csdn.net/Expert/topic/2980/2980550.xml?temp=.8290369要添加防崩溃模块代码请看 http://expert.csdn.net/Expert/TopicView1.asp?id=2859424
    添加了防崩溃模块代码后就可以把 Call InitExceptionHandler前的注释号去掉
      

  4.   

    恭喜绿豆变红星结贴后请加入faq支持
      

  5.   

    继续支持并抢分，把代码压缩一下放到 csdn 的软件下载上面吧，到时候把网址公布出来。
      

  6.   

    ********************* 研究小记 *********************VB在不同编译模式下的错误处理是不同的，其大致可分为三类：
    1.开发环境下的错误处理
    2.P代码(P-Code)方式编译后的错误处理
    3.本地代码(Native)方式编译后的错误处理在开发环境和P代码方式下，VB是使用运行库中的解释引擎来执行伪代码的，前者使用VBA6.DLL后者用到MSVBVM60.DLL。而本地代码方式则是将程序直接编译。在本地代码模式下，VB直接将错误处理程序的地址以结构化异常处理(SEH)的方式插入了每一段子程序,因此在这种模式下可以很轻松地得到错误处理程序的地址。而其他两种模式下，用普通获得SEH程序地址的方法得到的是解释引擎的SEH地址，因此不能用上述方法来实现……最后贴一下关键部分的汇编代码修改跳转表，指向自己的地址
    jmp [msvbvm60!__vbaexcepthandler]
    -->
    jmp [m_lJumpAddress]
    自己的处理程序
    [m_lJumpAddress]
    -->
    call [lMyEHAddress]
    jmp [msvbvm60!__vbaexcepthandler]
    以上是本人的初步研究成果，希望能够起到一点抛砖引玉的作用……