csocketmaster.cls

来自「支持监控包括传输控制协议和 UDP 的所有的互联网传输协议。同时程序具有实时文件」· CLS 代码 · 共 1,026 行 · 第 1/3 页

        m_lngLocalPortBind = 0
        m_strRemoteHostIP = vbNullString
        m_strRecvBuffer = vbNullString
        m_strSendBuffer = vbNullString
        m_lngSendBufferLen = 0
        m_lngRecvBufferLen = 0
        m_enmState = sckClosed
    End If
End Sub
Public Sub Connect(Optional RemoteHost As Variant, _
                   Optional RemotePort As Variant)
Dim lngAddress As Long
    On Error Resume Next
    If m_enmState <> sckClosed Then
        Err.Raise sckInvalidOp, "CSocketMaster.Connect", "Invalid operation at current state"
    End If
    If Not IsMissing(RemoteHost) Then
        m_strRemoteHost = CStr(RemoteHost)
    End If
    If m_strRemoteHost = vbNullString Then
        m_strRemoteHost = vbNullString
    End If
    If Not IsMissing(RemotePort) Then
        If IsNumeric(RemotePort) Then
            If CLng(RemotePort) > 65535 Or CLng(RemotePort) < 1 Then
                Err.Raise sckInvalidArg, "CSocketMaster.Connect", "The argument passed to a function was not in the correct format or in the specified range."
            Else
                m_lngRemotePort = CLng(RemotePort)
            End If
        Else
            Err.Raise sckUnsupported, "CSocketMaster.Connect", "Unsupported variant type."
        End If
    End If
    If Not SocketExists Then
        Exit Sub
    End If
    If m_enmProtocol = sckUDPProtocol Then
        If BindInternal Then
            m_enmState = sckOpen
        End If
        Exit Sub
    End If
    lngAddress = ResolveIfHostname(m_strRemoteHost, destConnect)
    If lngAddress <> vbNull Then
        ConnectToIP lngAddress, 0
    End If
    On Error GoTo 0
End Sub
Private Sub ConnectToIP(ByVal lngRemoteHostAddress As Long, _
                        ByVal lngErrorCode As Long)
Dim blnCancelDisplay As Boolean
Dim udtSockAddr      As sockaddr_in
Dim lngResult        As Long
    If lngErrorCode <> 0 Then
        m_enmState = sckError
        blnCancelDisplay = True
        RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ConnectToIP", "", 0, blnCancelDisplay)
    Else
        If Not BindInternal Then
            Exit Sub
        End If
        m_enmState = sckConnecting
        With udtSockAddr
            .sin_addr = lngRemoteHostAddress
            .sin_family = AF_INET
            .sin_port = api_htons(modSocketMaster.UnsignedToInteger(m_lngRemotePort))
        End With
        lngResult = api_connect(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
        If lngResult = SOCKET_ERROR Then
            lngErrorCode = Err.LastDllError
            If lngErrorCode <> WSAEWOULDBLOCK Then
                If lngErrorCode = WSAEADDRNOTAVAIL Then
                    Err.Raise WSAEADDRNOTAVAIL, "CSocketMaster.ConnectToIP", GetErrorDescription(WSAEADDRNOTAVAIL)
                Else
                    m_enmState = sckError
                    blnCancelDisplay = True
                    RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ConnectToIP", "", 0, blnCancelDisplay)
                End If
            End If
        End If
    End If
End Sub
Private Sub DestroySocket()
Dim lngResult    As Long
Dim lngErrorCode As Long
    If Not m_lngSocketHandle = INVALID_SOCKET Then
        lngResult = api_closesocket(m_lngSocketHandle)
        If lngResult = SOCKET_ERROR Then
            m_enmState = sckError
            Debug.Print "STATE: sckError"
            lngErrorCode = Err.LastDllError
            Err.Raise lngErrorCode, "CSocketMaster.DestroySocket", GetErrorDescription(lngErrorCode)
        Else
            modSocketMaster.UnregisterSocket m_lngSocketHandle
            m_lngSocketHandle = INVALID_SOCKET
        End If
    End If
End Sub
Private Sub EmptyBuffer()
Dim b As Byte
    api_recv m_lngSocketHandle, b, Len(b), 0&
End Sub
Private Sub FreeMemory()
    If m_lngMemoryHandle <> 0 Then
        m_lngMemoryHandle = 0
        m_lngMemoryPointer = 0
        api_GlobalFree m_lngMemoryHandle
    End If
End Sub
Private Function GetBufferLenUDP() As Long
Dim lngResult As Long
Dim lngBuffer As Long
    lngResult = api_ioctlsocket(m_lngSocketHandle, FIONREAD, lngBuffer)
    If lngResult = SOCKET_ERROR Then
        GetBufferLenUDP = 0
    Else
        GetBufferLenUDP = lngBuffer
    End If
End Function
Public Sub GetData(ByRef data As Variant, _
                   Optional varVarType As Variant, _
                   Optional maxLen As Variant)
    If m_enmProtocol = sckTCPProtocol Then
        If m_enmState <> sckConnected And Not m_blnAcceptClass Then
            Err.Raise sckBadState, "CSocketMaster.GetData", "Wrong protocol or connection state for the requested transaction or request"
            Exit Sub
        End If
    Else
        If m_enmState <> sckOpen Then
            Err.Raise sckBadState, "CSocketMaster.GetData", "Wrong protocol or connection state for the requested transaction or request"
            Exit Sub
        End If
        If GetBufferLenUDP = 0 Then
            Exit Sub
        End If
    End If
    If Not IsMissing(maxLen) Then
        If IsNumeric(maxLen) Then
            If CLng(maxLen) < 0 Then
                Err.Raise sckInvalidArg, "CSocketMaster.GetData", "The argument passed to a function was not in the correct format or in the specified range."
            End If
        Else
            If m_enmProtocol = sckTCPProtocol Then
                maxLen = Len(m_strRecvBuffer)
            Else
                maxLen = GetBufferLenUDP
            End If
        End If
    End If
    RecvData data, False, varVarType, maxLen
End Sub
Private Function GetLocalHostName() As String
Dim strHostNameBuf As String * LOCAL_HOST_BUFF
Dim lngResult      As Long
Dim lngErrorCode   As Long
    lngResult = api_gethostname(strHostNameBuf, LOCAL_HOST_BUFF)
    If lngResult = SOCKET_ERROR Then
        GetLocalHostName = vbNullString
        lngErrorCode = Err.LastDllError
        Err.Raise lngErrorCode, "CSocketMaster.GetLocalHostName", GetErrorDescription(lngErrorCode)
    Else
        GetLocalHostName = Left$(strHostNameBuf, InStr(1, strHostNameBuf, vbNullChar) - 1)
    End If
End Function
Private Function GetLocalIP() As String
Dim lngResult            As Long
Dim lngPtrToIP           As Long
Dim strLocalHost         As String
Dim arrIpAddress(1 To 4) As Byte
Dim Count                As Long
Dim udtHostent           As Hostent
Dim strIpAddress         As String
Dim lngErrorCode         As Long
    strLocalHost = GetLocalHostName
    lngResult = api_gethostbyname(strLocalHost)
    If lngResult = 0 Then
        GetLocalIP = vbNullString
        lngErrorCode = Err.LastDllError
        Err.Raise lngErrorCode, "CSocketMaster.GetLocalIP", GetErrorDescription(lngErrorCode)
    Else
        api_CopyMemory udtHostent, ByVal lngResult, LenB(udtHostent)
        api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4
        api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4
        For Count = 1 To 4
            strIpAddress = strIpAddress & arrIpAddress(Count) & "."
        Next Count
        strIpAddress = Left$(strIpAddress, Len(strIpAddress) - 1)
        GetLocalIP = strIpAddress
    End If
End Function
Private Function GetLocalPort(ByVal lngSocket As Long) As Long
Dim udtSockAddr As sockaddr_in
Dim lngResult   As Long
    lngResult = api_getsockname(lngSocket, udtSockAddr, LenB(udtSockAddr))
    If lngResult = SOCKET_ERROR Then
        GetLocalPort = SOCKET_ERROR
    Else
        GetLocalPort = modSocketMaster.IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port))
    End If
End Function
Private Function GetRemoteInfo(ByVal lngSocket As Long, _
                               ByRef lngRemotePort As Long, _
                               ByRef strRemoteHostIP As String, _
                               ByRef strRemoteHost As String) As Boolean
Dim lngResult   As Long
Dim udtSockAddr As sockaddr_in
    GetRemoteInfo = False
    lngResult = api_getpeername(lngSocket, udtSockAddr, LenB(udtSockAddr))
    If lngResult = 0 Then
        GetRemoteInfo = True
        GetRemoteInfoFromSI udtSockAddr, lngRemotePort, strRemoteHostIP, strRemoteHost
    Else
        lngRemotePort = 0
        strRemoteHostIP = vbNullString
        strRemoteHost = vbNullString
    End If
End Function
Private Sub GetRemoteInfoFromSI(ByRef udtSockAddr As sockaddr_in, _
                                ByRef lngRemotePort As Long, _
                                ByRef strRemoteHostIP As String, _
                                ByRef strRemoteHost As String)
    lngRemotePort = IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port))
    strRemoteHostIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr))
    m_strRemoteHost = vbNullString
End Sub
Public Property Get LocalHostName() As String
    LocalHostName = GetLocalHostName
End Property
Public Property Get LocalIP() As String
    If m_enmState = sckOpen Or m_enmState = sckListening Then
        LocalIP = m_strLocalIP
    Else
        LocalIP = GetLocalIP
    End If
End Property
Public Property Get LocalPort() As Long
    If m_lngLocalPortBind = 0 Then
        LocalPort = m_lngLocalPort
    Else
        LocalPort = m_lngLocalPortBind
    End If
End Property
Public Property Let LocalPort(ByVal lngPort As Long)
    If m_enmState <> sckClosed Then
        Err.Raise sckInvalidOp, "CSocketMaster.LocalPort", "Invalid operation at current state"
    End If
    If lngPort < 0 Or lngPort > 65535 Then
        Err.Raise sckInvalidArg, "CSocketMaster.LocalPort", "The argument passed to a function was not in the correct format or in the specified range."
    Else
        m_lngLocalPort = lngPort
    End If
End Property
Private Sub ProcessOptions()
Dim lngResult    As Long
Dim lngBuffer    As Long
Dim lngErrorCode As Long
    If m_enmProtocol = sckTCPProtocol Then
        lngResult = api_getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_RCVBUF, lngBuffer, LenB(lngBuffer))
        If lngResult = SOCKET_ERROR Then
            lngErrorCode = Err.LastDllError
            Err.Raise lngErrorCode, "CSocketMaster.ProcessOptions", GetErrorDescription(lngErrorCode)
        Else
            m_lngRecvBufferLen = lngBuffer
        End If
        lngResult = api_getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_SNDBUF, lngBuffer, LenB(lngBuffer))
        If lngResult = SOCKET_ERROR Then
            lngErrorCode = Err.LastDllError
            Err.Raise lngErrorCode, "CSocketMaster.ProcessOptions", GetErrorDescription(lngErrorCode)
        Else
            m_lngSendBufferLen = lngBuffer
        End If
    Else
        lngBuffer = 1
        lngResult = api_setsockopt(m_lngSocketHandle, SOL_SOCKET, SO_BROADCAST, lngBuffer, LenB(lngBuffer))
        lngResult = api_getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_MAX_MSG_SIZE, lngBuffer, LenB(lngBuffer))
        If lngResult = SOCKET_ERROR Then
            lngErrorCode = Err.LastDllError
            Err.Raise lngErrorCode, "CSocketMaster.ProcessOptions", GetErrorDescription(lngErrorCode)
        Else
            m_lngRecvBufferLen = lngBuffer
            m_lngSendBufferLen = lngBuffer
        End If
    End If
End Sub
Public Property Get Protocol() As ProtocolConstants
    Protocol = m_enmProtocol
End Property
Public Property Let Protocol(ByVal enmProtocol As ProtocolConstants)
    If m_enmState <> sckClosed Then
        Err.Raise sckInvalidOp, "CSocketMaster.Protocol", "Invalid operation at current state"
    Else
        m_enmProtocol = enmProtocol
    End If
End Property
Private Function RecvData(ByRef data As Variant, _
                          ByVal blnPeek As Boolean, _
                          Optional varClass As Variant, _
                          Optional maxLen As Variant) As Long
Dim blnMaxLenMiss As Boolean
Dim blnClassMiss  As Boolean
Dim lngBufferLen  As Long
Dim arrBuffer()   As Byte
Dim lngErrorCode  As Long
Dim strdata       As String
Dim blnData       As Boolean
Dim bytData       As Byte
Dim curData       As Currency
Dim datData       As Date
Dim dblData       As Double
Dim intData       As Long
Dim lngData       As Long
Dim sngData       As Single
'Dim strRecvData     As String
    If m_enmProtocol = sckTCPProtocol Then
        lngBufferLen = Len(m_strRecvBuffer)
    Else
        lngBufferLen = GetBufferLenUDP
    End If
    blnMaxLenMiss = IsMissing(maxLen)
    blnClassMiss = IsMissing(varClass)
    If VarType(data) = vbEmpty Then
        If blnClassMiss Then
            varClass = vbArray + vbByte
        End If
    Else
        varClass = VarType(data)
    End If
    If varClass = vbString Or varClass = vbArray + vbByte Then
        If blnMaxLenMiss Then 'if maxLen argument is missing
            If lngBufferLen = 0 Then
                RecvData = 0
                arrBuffer = StrConv(vbNullString, vbFromUnicode)
                data = arrBuffer
                Exit Function
            Else
                RecvData = lngBufferLen
                arrBuffer = BuildArray(lngBufferLen, blnPeek, lngErrorCode)
            End If
        Else 'if maxLen argument is not missing
            If maxLen = 0 Or lngBufferLen = 0 Then
                RecvData = 0
                arrBuffer = StrConv(vbNullString, vbFromUnicode)