vberrcatcher.cls

vb中不能呼叫vc或其他程序编译的dll文件

    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 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
       
    Select Case m_lWhereAmI
    Case evaNative
        'int 3 ;测试用
        'AddByteToCode &HCC, bCodeBytes(), lLastPos
        
        '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
    Case evaDev
        'push VBA6!StdThrow
        AddByteToCode &H68, bCodeBytes(), lLastPos
        AddLongToCode m_lTargetAddress + 5, bCodeBytes(), lLastPos
        'call lMyEHAddress
        AddByteToCode &HE8, bCodeBytes(), lLastPos
        AddLongToCode lMyEHAddress - (m_lCodeBufferAddress + VarPtr(bCodeBytes(lLastPos)) - VarPtr(bCodeBytes(0))) - 4, bCodeBytes(), lLastPos
        'ret
        AddByteToCode &HC3, bCodeBytes(), lLastPos
    Case evaPCode
        
        'call lMyEHAddress
        AddByteToCode &HE8, bCodeBytes(), lLastPos
        AddLongToCode lMyEHAddress - (m_lCodeBufferAddress + VarPtr(bCodeBytes(lLastPos)) - VarPtr(bCodeBytes(0))) - 4, bCodeBytes(), lLastPos
        
        'pop eax
        AddByteToCode &H58, bCodeBytes(), lLastPos
        
        'call unwind
        AddByteToCode &HE8, bCodeBytes(), lLastPos
        AddLongToCode m_lTargetAddress + 27 - (m_lCodeBufferAddress + VarPtr(bCodeBytes(lLastPos)) - VarPtr(bCodeBytes(0))) - 4, bCodeBytes(), lLastPos
        
        'jmp back
        AddByteToCode &HE9, bCodeBytes(), lLastPos
        AddLongToCode m_lTargetAddress + 5 - (m_lCodeBufferAddress + VarPtr(bCodeBytes(lLastPos)) - VarPtr(bCodeBytes(0))) - 4, bCodeBytes(), lLastPos
    End Select
    
    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 AddByteStrToCode(ByVal sCodeBytes As String, bCodeBytes() As Byte, lPos As Long) As Long
    Dim i As Long
    Dim asCodeByte() As String
    asCodeByte = Split(sCodeBytes, " ")
    For i = 0 To UBound(asCodeByte)
        AddByteToCode CByte("&H" & asCodeByte(i)), bCodeBytes(), lPos
    Next
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 Function GetTargetAddress() As Long
    Select Case m_lWhereAmI
    Case evaNative
        GetTargetAddress = m_lEHAddress
    Case evaDev
        GetTargetAddress = GetProcAddress(m_lhModVBA6, "StdThrow") - 5
    Case evaPCode
        GetTargetAddress = LocateTarget
    Case Else
        Exit Function
    End Select
End Function

Private Function LocateTarget() As Long
    On Error Resume Next
    Dim ppvData As Long
    Dim pvData As Long
    Dim ppSA As Long
    Dim pSA As Long
    Dim lVal As Long
    Dim lpAddr As Long
    
    Dim bTarget(&H110000) As Byte
    Dim bFind() As Byte
    
    If m_lWhereAmI <> evaPCode Then Exit Function
    
    bFind = m_oAnyCall.ByteCodeStrToBin(MAGIC_STRING)
    
    lpAddr = m_lhModMSVBVM
    
    If Err.Number <> 0 Then Exit Function
    
    ppSA = VarPtrArray(bTarget())
    pSA = GetArrayPtr(ppSA)
    ppvData = pSA + 12
    
    CopyMemory pvData, ByVal ppvData, 4
    CopyMemory ByVal ppvData, lpAddr, 4
    
    LocateTarget = InStrB(bTarget, bFind)
    
    CopyMemory ByVal ppvData, pvData, 4
    
    If LocateTarget <> 0 Then
        LocateTarget = LocateTarget + lpAddr - 1
    End If
End Function

Private Function GetArrayPtr(ByVal ppSA As Long) As Long
    CopyMemory GetArrayPtr, ByVal ppSA, 4
End Function

Private Function SysDir() As String
    Dim s As String * 255
    Dim l As Long
    l = GetSystemDirectory(s, 255)
    SysDir = Left(s, l)
End Function
Private Function GetRegionSize(ByVal lAddr As Long) As Long
    Dim hProcess As Long
    Dim mi As MEMORY_BASIC_INFORMATION
    Dim lpAddress 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
            Stop
            GetRegionSize = mi.RegionSize
        End If
        CloseHandle hProcess
    End If
End Function
Private Sub Class_Initialize()
    m_lhModVBA6 = GetModuleHandle("vba6.dll")
    m_lhModMSVBVM = GetModuleHandle("msvbvm60.dll")
    
    Set m_oAnyCall = New CVBAnyCall
    With m_oAnyCall
        .IsStandardCall = False
        .ThroughVTable = True
    End With
    
    Call GetEHAddress
    m_lTargetAddress = GetTargetAddress
End Sub

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