modsocketmaster.bas

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

End Function
Public Function GetAcceptClass(ByVal lngSocket As Long) As CSocketMaster
    Set GetAcceptClass = m_colAcceptList("S" & lngSocket)
End Function
Public Function GetErrorDescription(ByVal lngErrorCode As Long) As String
    Select Case lngErrorCode
    Case WSAEACCES
        GetErrorDescription = "Permission denied."
    Case WSAEADDRINUSE
        GetErrorDescription = "Address already in use."
    Case WSAEADDRNOTAVAIL
        GetErrorDescription = "Cannot assign requested address."
    Case WSAEAFNOSUPPORT
        GetErrorDescription = "Address family not supported by protocol family."
    Case WSAEALREADY
        GetErrorDescription = "Operation already in progress."
    Case WSAECONNABORTED
        GetErrorDescription = "Software caused connection abort."
    Case WSAECONNREFUSED
        GetErrorDescription = "Connection refused."
    Case WSAECONNRESET
        GetErrorDescription = "Connection reset by peer."
    Case WSAEDESTADDRREQ
        GetErrorDescription = "Destination address required."
    Case WSAEFAULT
        GetErrorDescription = "Bad address."
    Case WSAEHOSTUNREACH
        GetErrorDescription = "No route to host."
    Case WSAEINPROGRESS
        GetErrorDescription = "Operation now in progress."
    Case WSAEINTR
        GetErrorDescription = "Interrupted function call."
    Case WSAEINVAL
        GetErrorDescription = "Invalid argument."
    Case WSAEISCONN
        GetErrorDescription = "Socket is already connected."
    Case WSAEMFILE
        GetErrorDescription = "Too many open files."
    Case WSAEMSGSIZE
        GetErrorDescription = "Message too long."
    Case WSAENETDOWN
        GetErrorDescription = "Network is down."
    Case WSAENETRESET
        GetErrorDescription = "Network dropped connection on reset."
    Case WSAENETUNREACH
        GetErrorDescription = "Network is unreachable."
    Case WSAENOBUFS
        GetErrorDescription = "No buffer space available."
    Case WSAENOPROTOOPT
        GetErrorDescription = "Bad protocol option."
    Case WSAENOTCONN
        GetErrorDescription = "Socket is not connected."
    Case WSAENOTSOCK
        GetErrorDescription = "Socket operation on nonsocket."
    Case WSAEOPNOTSUPP
        GetErrorDescription = "Operation not supported."
    Case WSAEPFNOSUPPORT
        GetErrorDescription = "Protocol family not supported."
    Case WSAEPROCLIM
        GetErrorDescription = "Too many processes."
    Case WSAEPROTONOSUPPORT
        GetErrorDescription = "Protocol not supported."
    Case WSAEPROTOTYPE
        GetErrorDescription = "Protocol wrong type for socket."
    Case WSAESHUTDOWN
        GetErrorDescription = "Cannot send after socket shutdown."
    Case WSAESOCKTNOSUPPORT
        GetErrorDescription = "Socket type not supported."
    Case WSAETIMEDOUT
        GetErrorDescription = "Connection timed out."
    Case WSAEWOULDBLOCK
        GetErrorDescription = "Resource temporarily unavailable."
    Case WSAHOST_NOT_FOUND
        GetErrorDescription = "Host not found."
    Case WSANOTINITIALISED
        GetErrorDescription = "Successful WSAStartup not yet performed."
    Case WSANO_DATA
        GetErrorDescription = "Valid name, no data record of requested type."
    Case WSANO_RECOVERY
        GetErrorDescription = "This is a nonrecoverable error."
    Case WSASYSNOTREADY
        GetErrorDescription = "Network subsystem is unavailable."
    Case WSATRY_AGAIN
        GetErrorDescription = "Nonauthoritative host not found."
    Case WSAVERNOTSUPPORTED
        GetErrorDescription = "Winsock.dll version out of range."
    Case Else
        GetErrorDescription = "Unknown error."
    End Select
End Function
Public Function HiWord(lngValue As Long) As Long
    If (lngValue And &H80000000) = &H80000000 Then
        HiWord = ((lngValue And &H7FFF0000) \ &H10000) Or &H8000&
    Else
        HiWord = (lngValue And &HFFFF0000) \ &H10000
    End If
End Function
Public Function InitiateProcesses() As Long
Dim lngResult As Long
    InitiateProcesses = 0
    m_lngSocksQuantity = m_lngSocksQuantity + 1
    If Not m_blnInitiated Then
        Subclass_Initialize
        m_blnInitiated = True
        lngResult = InitiateService
        If lngResult <> 0 Then
            Err.Raise lngResult, "modSocketMaster.InitiateProcesses", GetErrorDescription(lngResult)
            InitiateProcesses = lngResult
        End If
    End If
End Function
Private Function InitiateService() As Long
Dim udtWSAData As WSAdata
Dim lngResult  As Long
    lngResult = api_WSAStartup(SOCKET_VERSION_11, udtWSAData)
    InitiateService = lngResult
End Function
Public Function IntegerToUnsigned(Value As Long) As Long
    If Value < 0 Then
        IntegerToUnsigned = Value + OFFSET_2
    Else
        IntegerToUnsigned = Value
    End If
End Function
Public Function IsAcceptRegistered(ByVal lngSocket As Long) As Boolean
    On Error GoTo Error_Handler
    m_colAcceptList.Item ("S" & lngSocket)
    IsAcceptRegistered = True
Exit Function
Error_Handler:
    IsAcceptRegistered = False
End Function
Public Function IsSocketRegistered(ByVal lngSocket As Long) As Boolean
    On Error GoTo Error_Handler
    m_colSocketsInst.Item ("S" & lngSocket)
    IsSocketRegistered = True
Exit Function
Error_Handler:
    IsSocketRegistered = False
End Function
Public Function LoWord(lngValue As Long) As Long
    LoWord = (lngValue And &HFFFF&)
End Function
Public Function RegisterSocket(ByVal lngSocket As Long, _
                               ByVal lngObjectPointer As Long, _
                               ByVal blnEvents As Boolean) As Boolean
Dim lngEvents    As Long
Dim lngResult    As Long
Dim lngErrorCode As Long
    If m_colSocketsInst Is Nothing Then
        Set m_colSocketsInst = New Collection
        If CreateWinsockMessageWindow <> 0 Then
            Err.Raise sckOutOfMemory, "modSocketMaster.RegisterSocket", "Out of memory"
        End If
        Subclass_Subclass (m_lngWindowHandle)
    End If
    Subclass_AddSocketMessage lngSocket, lngObjectPointer
    If blnEvents Then
        lngEvents = FD_READ Or FD_WRITE Or FD_ACCEPT Or FD_CONNECT Or FD_CLOSE
        lngResult = api_WSAAsyncSelect(lngSocket, m_lngWindowHandle, SOCKET_MESSAGE, lngEvents)
        If lngResult = SOCKET_ERROR Then
            lngErrorCode = Err.LastDllError
            Err.Raise lngErrorCode, "modSocketMaster.RegisterSocket", GetErrorDescription(lngErrorCode)
        End If
    End If
    m_colSocketsInst.Add lngObjectPointer, "S" & lngSocket
    RegisterSocket = True
End Function
Public Function ResolveHost(ByVal strHost As String, _
                            ByVal lngHOSTENBuf As Long, _
                            ByVal lngObjectPointer As Long) As Long
Dim lngAsynHandle As Long
    lngAsynHandle = api_WSAAsyncGetHostByName(m_lngWindowHandle, RESOLVE_MESSAGE, strHost, ByVal lngHOSTENBuf, MAXGETHOSTSTRUCT)
    If lngAsynHandle <> 0 Then
        Subclass_AddResolveMessage lngAsynHandle, lngObjectPointer
    End If
    ResolveHost = lngAsynHandle
End Function
Public Function StringFromPointer(ByVal lPointer As Long) As String
Dim strTemp As String
Dim lRetVal As Long
    strTemp = String$(api_lstrlen(ByVal lPointer), 0)
    lRetVal = api_lstrcpy(ByVal strTemp, ByVal lPointer)
    If lRetVal Then
        StringFromPointer = strTemp
    End If
End Function
Private Sub Subclass_AddResolveMessage(ByVal lngAsync As Long, _
                                       ByVal lngObjectPointer As Long)
Dim Count As Long
    For Count = 1 To lngMsgCntA
        Select Case lngTableA1(Count)
        Case -1
            lngTableA1(Count) = lngAsync
            lngTableA2(Count) = lngObjectPointer
            Exit Sub
        Case lngAsync
            Exit Sub
        End Select
    Next Count
    lngMsgCntA = lngMsgCntA + 1
    ReDim Preserve lngTableA1(1 To lngMsgCntA)
    ReDim Preserve lngTableA2(1 To lngMsgCntA)
    lngTableA1(lngMsgCntA) = lngAsync
    lngTableA2(lngMsgCntA) = lngObjectPointer
    Subclass_PatchTableA
End Sub
Private Function Subclass_AddrFunc(ByVal sDLL As String, _
                                   ByVal sProc As String) As Long
    Subclass_AddrFunc = api_GetProcAddress(api_GetModuleHandle(sDLL), sProc)
End Function
Private Function Subclass_AddrMsgTbl(ByRef aMsgTbl() As Long) As Long
    On Error Resume Next
'Return the address of the low bound of the passed table array
'The table may not be dimensioned yet so we need protection
    Subclass_AddrMsgTbl = VarPtr(aMsgTbl(1))
'Get the address of the first element of the passed message table
    On Error GoTo 0                                         'Switch off error protection
End Function
Private Sub Subclass_AddSocketMessage(ByVal lngSocket As Long, _