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

[supergreenbean]

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 Long

Private 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 Type

Private Const PROCESS_ALL_ACCESS = &H1F0FFF

Private 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 Enum

Private 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 Boolean

Private 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

'******************************* 暴露的接口 *******************************

[supergreenbean]

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 Property

Private 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 Function

Private 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 Function

Private 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 Function

Private 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 Function

Private Function AddByteToCode(ByVal bCode As Byte, bCodeBytes() As Byte, lPos As Long) As Long
bCodeBytes(lPos) = bCode
lPos = lPos + 1
End Function

Private Function AddLongToCode(ByVal lCode As Long, bCodeBytes() As Byte, lPos As Long) As Long
CopyMemory bCodeBytes(lPos), lCode, 4
lPos = lPos + 4
End Function

Private 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 Function

Private 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 Function

Private 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 Sub

Private Sub Class_Terminate()
Set m_oAnyCall = Nothing
End Sub
'******************************** 私有函数 ********************************

[supergreenbean]

使用例子：

'------------------------------ 窗体模块 Form2.frm ------------------------------
Option Explicit
'本模块名称
Private Const THIS_MODULE_NAME As String = "Form2"

Private WithEvents cmd As CommandButton

Private Sub cmd_Click()
'一定要加上on error resume next这句,否则程序便会中止
On Error Resume Next
MsgBox "就要发生错误了"
MsgBox 1 / 0
MsgBox "这是下一句"
End Sub

Private Sub Form_Initialize()
'使用SEH，防止程序崩溃
Call InitExceptionHandler
End Sub

Private 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 Sub

Private 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 CVBErrCatcher

Public Function MyEH() As Long
MsgBox "有错误发生!错误描述为:" & Err.Description, , "自定义错误处理函数"
End Function

[supergreenbean]

测试方法：
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前的注释号去掉

[online]

恭喜绿豆变红星

结贴后请加入faq

支持

[铁拳]

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

[Drowning]

恭喜

[supergreenbean]

********************* 研究小记 *********************

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]


以上是本人的初步研究成果，希望能够起到一点抛砖引玉的作用……

[programfish]

关注

[onlineboy]

up

[realmayer7903]

不错
顺便接分

[高高兴兴的晶晶]

看看先

[Kivic]

好东西，收藏