modsocketmaster.bas

支持监控包括传输控制协议和 UDP 的所有的互联网传输协议。同时程序具有实时文件防修改监控功能

                                      ByVal lngObjectPointer As Long)
Dim Count As Long
    For Count = 1 To lngMsgCntB
        Select Case lngTableB1(Count)
        Case -1
            lngTableB1(Count) = lngSocket
            lngTableB2(Count) = lngObjectPointer
            Exit Sub
        Case lngSocket
            Exit Sub
        End Select
    Next Count
    lngMsgCntB = lngMsgCntB + 1
    ReDim Preserve lngTableB1(1 To lngMsgCntB)
    ReDim Preserve lngTableB2(1 To lngMsgCntB)
    lngTableB1(lngMsgCntB) = lngSocket
    lngTableB2(lngMsgCntB) = lngObjectPointer
    Subclass_PatchTableB
End Sub
Public Sub Subclass_ChangeOwner(ByVal lngSocket As Long, _
                                ByVal lngObjectPointer As Long)
Dim Count As Long
    For Count = 1 To lngMsgCntB
        If lngTableB1(Count) = lngSocket Then
            lngTableB2(Count) = lngObjectPointer
            Exit For
        End If
    Next Count
End Sub
Private Sub Subclass_DelResolveMessage(ByVal lngAsync As Long)
Dim Count As Long
    For Count = 1 To lngMsgCntA
        If lngTableA1(Count) = lngAsync Then
            lngTableA1(Count) = -1
            lngTableA2(Count) = -1
            Exit For
        End If
    Next Count
End Sub
Private Sub Subclass_DelSocketMessage(ByVal lngSocket As Long)
Dim Count As Long
    For Count = 1 To lngMsgCntB
        If lngTableB1(Count) = lngSocket Then
            lngTableB1(Count) = -1
            lngTableB2(Count) = -1
            Exit For
        End If
    Next Count
End Sub
Private Function Subclass_InIDE() As Boolean
    Debug.Assert Subclass_SetTrue(Subclass_InIDE)
End Function
Private Sub Subclass_Initialize()
Const PATCH_01 As Long = 15
Const PATCH_03 As Long = 76                   'Relative address of SetWindowsLong
Const PATCH_05 As Long = 100                  'Relative address of CallWindowProc
Const FUNC_EBM As String = "EbMode"
Const FUNC_SWL As String = "SetWindowLongA"
Const FUNC_CWP As String = "CallWindowProcA"  'We use CallWindowProc to call the original WndProc
Const MOD_VBA5 As String = "vba5"             'Location of the EbMode function if running VB5
Const MOD_VBA6 As String = "vba6"             'Location of the EbMode function if running VB6
Const MOD_USER As String = "user32"
Dim i          As Long                        'Loop index
Dim nLen       As Long                        'String lengths
Dim sHex       As String                      'Hex code string
Dim sCode      As String                      'Binary code string
'Code buffer offset to the location of the relative address to EbMode
'VBA's EbMode function allows the machine code thunk to know if the IDE has stopped or is on a breakpoint
'SetWindowLong allows the cSubclasser machine code thunk to unsubclass the subclasser itself if it detects via the EbMode function that the IDE has stopped
'Location of the SetWindowLong & CallWindowProc functions
    sHex = "5850505589E55753515231C0EB0EE8xxxxx01x83F802742285C074258B45103D0008000074433D01080000745BE8200000005A595B5FC9C21400E813000000EBF168xxxxx02x6AFCFF750CE8xxxxx03xEBE0FF7518FF7514FF7510FF750C68xxxxx04xE8xxxxx05xC3BBxxxxx06x8B4514BFxxxxx07x89D9F2AF75B629CB4B8B1C9Dxxxxx08xEB1DBBxxxxx09x8B4514BFxxxxx0Ax89D9F2AF759729CB4B8B1C9Dxxxxx0Bx895D088B1B8B5B1C89D85A595B5FC9FFE0"
    nLen = Len(sHex)                                          'Length of hex pair string
    For i = 1 To nLen Step 2                                  'For each pair of hex characters
        sCode = sCode & ChrB$(Val("&H" & Mid$(sHex, i, 2)))
'Convert a pair of hex characters to a byte and append to the ASCII string
    Next i                                                    'Next pair
    nLen = LenB(sCode)                                        'Get the machine code length
    nAddrSubclass = api_GlobalAlloc(0, nLen)
'Allocate fixed memory for machine code buffer
    Debug.Print "OK Subclass memory allocated at: " & nAddrSubclass
'Copy the code to allocated memory
    api_CopyMemory ByVal nAddrSubclass, ByVal StrPtr(sCode), nLen
    If Subclass_InIDE Then
'Patch the jmp (EB0E) with two nop's (90) enabling the IDE breakpoint/stop checking code
        api_CopyMemory ByVal nAddrSubclass + 12, &H9090, 2
        i = Subclass_AddrFunc(MOD_VBA6, FUNC_EBM)
'Get the address of EbMode in vba6.dll
        If i = 0 Then                                           'Found?
            i = Subclass_AddrFunc(MOD_VBA5, FUNC_EBM)             'VB5 perhaps, try vba5.dll
        End If
        Debug.Assert i
'Ensure the EbMode function was found
        Subclass_PatchRel PATCH_01, i
'Patch the relative address to the EbMode api function
    End If
    Subclass_PatchRel PATCH_03, Subclass_AddrFunc(MOD_USER, FUNC_SWL)
'Address of the SetWindowLong api function
    Subclass_PatchRel PATCH_05, Subclass_AddrFunc(MOD_USER, FUNC_CWP)
'Address of the CallWindowProc api function
End Sub
Private Sub Subclass_PatchRel(ByVal nOffset As Long, _
                              ByVal nTargetAddr As Long)
    api_CopyMemory ByVal (nAddrSubclass + nOffset), nTargetAddr - nAddrSubclass - nOffset - 4, 4
End Sub
Private Sub Subclass_PatchTableA()
Const PATCH_07 As Long = 114
Const PATCH_08 As Long = 130
    Subclass_PatchVal PATCH_06, lngMsgCntA
    Subclass_PatchVal PATCH_07, Subclass_AddrMsgTbl(lngTableA1)
    Subclass_PatchVal PATCH_08, Subclass_AddrMsgTbl(lngTableA2)
End Sub
Private Sub Subclass_PatchTableB()
Const PATCH_0A As Long = 145
Const PATCH_0B As Long = 161
    Subclass_PatchVal PATCH_09, lngMsgCntB
    Subclass_PatchVal PATCH_0A, Subclass_AddrMsgTbl(lngTableB1)
    Subclass_PatchVal PATCH_0B, Subclass_AddrMsgTbl(lngTableB2)
End Sub
Private Sub Subclass_PatchVal(ByVal nOffset As Long, _
                              ByVal nValue As Long)
    api_CopyMemory ByVal (nAddrSubclass + nOffset), nValue, 4
End Sub
Private Function Subclass_SetTrue(bValue As Boolean) As Boolean
    Subclass_SetTrue = True
    bValue = True
End Function
Private Function Subclass_Subclass(ByVal lngHWnd As Long) As Boolean
Const PATCH_02 As Long = 66   'Address of the previous WndProc
Const PATCH_04 As Long = 95   'Address of the previous WndProc
'Set the window subclass
    If hWndSub = 0 Then
        Debug.Assert api_IsWindow(lngHWnd)                         'Invalid window handle
        hWndSub = lngHWnd                                          'Store the window handle
        nAddrOriginal = api_GetWindowLong(lngHWnd, GWL_WNDPROC)
        Subclass_PatchVal PATCH_02, nAddrOriginal
'Original WndProc address for CallWindowProc, call the original WndProc
        Subclass_PatchVal PATCH_04, nAddrOriginal
'Original WndProc address for SetWindowLong, unsubclass on IDE stop
        nAddrOriginal = api_SetWindowLong(lngHWnd, GWL_WNDPROC, nAddrSubclass)
        If nAddrOriginal <> 0 Then
            nAddrOriginal = 0
            Subclass_Subclass = True                                       'Success
        End If
    End If
    Debug.Assert Subclass_Subclass
End Function
Private Sub Subclass_Terminate()
    Subclass_UnSubclass
'UnSubclass and release the allocated memory
'UnSubclass if the Subclass thunk is active
    api_GlobalFree nAddrSubclass                            'Release the allocated memory
    nAddrSubclass = 0
    ReDim lngTableA1(1 To 1)
    ReDim lngTableA2(1 To 1)
    ReDim lngTableB1(1 To 1)
    ReDim lngTableB2(1 To 1)
End Sub
Private Function Subclass_UnSubclass() As Boolean
    If hWndSub <> 0 Then
'Stop subclassing the window
        lngMsgCntA = 0
        lngMsgCntB = 0
        Subclass_PatchVal PATCH_06, lngMsgCntA
'Patch the TableA entry count to ensure no further Proc callbacks
        Subclass_PatchVal PATCH_09, lngMsgCntB
'Patch the TableB entry count to ensure no further Proc callbacks
        api_SetWindowLong hWndSub, GWL_WNDPROC, nAddrOriginal
        hWndSub = 0
'Indicate the subclasser is inactive
        Subclass_UnSubclass = True                              'Success
    End If
End Function
Public Sub UnregisterAccept(ByVal lngSocket As Long)
    m_colAcceptList.Remove "S" & lngSocket
    If m_colAcceptList.Count = 0 Then
        Set m_colAcceptList = Nothing
    End If
End Sub
Public Sub UnregisterResolution(ByVal lngAsynHandle As Long)
    Subclass_DelResolveMessage lngAsynHandle
End Sub
Public Sub UnregisterSocket(ByVal lngSocket As Long)
    Subclass_DelSocketMessage lngSocket
    On Error Resume Next
    m_colSocketsInst.Remove "S" & lngSocket
    If m_colSocketsInst.Count = 0 Then
        Set m_colSocketsInst = Nothing
        Subclass_UnSubclass
        DestroyWinsockMessageWindow
    End If
    On Error GoTo 0
End Sub
Public Function UnsignedToInteger(Value As Long) As Long
' Overflow
    If Value < 0 Or Value >= OFFSET_2 Then
        Error 6
    End If
    If Value <= MAXINT_2 Then
        UnsignedToInteger = Value
    Else
        UnsignedToInteger = Value - OFFSET_2
    End If
End Function
''
''Public Sub RegisterAccept(ByVal lngSocket As Long)
''
''
''Dim Socket As CSocketMaster
''If m_colAcceptList Is Nothing Then
''Set m_colAcceptList = New Collection
''End If
''Set Socket = New CSocketMaster
''Socket.Accept lngSocket
''m_colAcceptList.Add Socket, "S" & lngSocket
''End Sub
''