实用代码（兼散分）：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 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

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