csocketmaster.cls

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

                data = arrBuffer
                If m_enmProtocol = sckUDPProtocol Then
                    EmptyBuffer
                    Err.Raise WSAEMSGSIZE, "CSocketMaster.RecvData", GetErrorDescription(WSAEMSGSIZE)
                End If
                Exit Function
            ElseIf maxLen > lngBufferLen Then
                RecvData = lngBufferLen
                arrBuffer = BuildArray(lngBufferLen, blnPeek, lngErrorCode)
            Else
                RecvData = CLng(maxLen)
                arrBuffer() = BuildArray(CLng(maxLen), blnPeek, lngErrorCode)
            End If
        End If
    End If
    Select Case varClass
    Case vbString
        strdata = StrConv(arrBuffer(), vbUnicode)
        data = strdata
    Case vbArray + vbByte
        data = arrBuffer
    Case vbBoolean
        If LenB(blnData) > lngBufferLen Then
            Exit Function
        End If
        arrBuffer = BuildArray(LenB(blnData), blnPeek, lngErrorCode)
        RecvData = LenB(blnData)
        api_CopyMemory blnData, arrBuffer(0), LenB(blnData)
        data = blnData
    Case vbByte
        If LenB(bytData) > lngBufferLen Then
            Exit Function
        End If
        arrBuffer = BuildArray(LenB(bytData), blnPeek, lngErrorCode)
        RecvData = LenB(bytData)
        api_CopyMemory bytData, arrBuffer(0), LenB(bytData)
        data = bytData
    Case vbCurrency
        If LenB(curData) > lngBufferLen Then
            Exit Function
        End If
        arrBuffer = BuildArray(LenB(curData), blnPeek, lngErrorCode)
        RecvData = LenB(curData)
        api_CopyMemory curData, arrBuffer(0), LenB(curData)
        data = curData
    Case vbDate
        If LenB(datData) > lngBufferLen Then
            Exit Function
        End If
        arrBuffer = BuildArray(LenB(datData), blnPeek, lngErrorCode)
        RecvData = LenB(datData)
        api_CopyMemory datData, arrBuffer(0), LenB(datData)
        data = datData
    Case vbDouble
        If LenB(dblData) > lngBufferLen Then
            Exit Function
        End If
        arrBuffer = BuildArray(LenB(dblData), blnPeek, lngErrorCode)
        RecvData = LenB(dblData)
        api_CopyMemory dblData, arrBuffer(0), LenB(dblData)
        data = dblData
    Case vbInteger
        If LenB(intData) > lngBufferLen Then
            Exit Function
        End If
        arrBuffer = BuildArray(LenB(intData), blnPeek, lngErrorCode)
        RecvData = LenB(intData)
        api_CopyMemory intData, arrBuffer(0), LenB(intData)
        data = intData
    Case vbLong
        If LenB(lngData) > lngBufferLen Then
            Exit Function
        End If
        arrBuffer = BuildArray(LenB(lngData), blnPeek, lngErrorCode)
        RecvData = LenB(lngData)
        api_CopyMemory lngData, arrBuffer(0), LenB(lngData)
        data = lngData
    Case vbSingle
        If LenB(sngData) > lngBufferLen Then
            Exit Function
        End If
        arrBuffer = BuildArray(LenB(sngData), blnPeek, lngErrorCode)
        RecvData = LenB(sngData)
        api_CopyMemory sngData, arrBuffer(0), LenB(sngData)
        data = sngData
    Case Else
        Err.Raise sckUnsupported, "CSocketMaster.RecvData", "Unsupported variant type."
    End Select
    If lngErrorCode <> 0 Then
        Err.Raise lngErrorCode, "CSocketMaster.RecvData", GetErrorDescription(lngErrorCode)
    End If
End Function
Public Property Get RemoteHost() As String
    RemoteHost = m_strRemoteHost
End Property
Public Property Let RemoteHost(ByVal strHost As String)
    If m_enmProtocol = sckTCPProtocol Then
        If m_enmState <> sckClosed Then
            Err.Raise sckInvalidOp, "CSocketMaster.RemoteHost", "Invalid operation at current state"
        End If
    End If
    m_strRemoteHost = strHost
End Property
Public Property Get RemoteHostIP() As String
    RemoteHostIP = m_strRemoteHostIP
End Property
Public Property Get RemotePort() As Long
    RemotePort = m_lngRemotePort
End Property
Public Property Let RemotePort(ByVal lngPort As Long)
    If m_enmProtocol = sckTCPProtocol Then
        If m_enmState <> sckClosed Then
            Err.Raise sckInvalidOp, "CSocketMaster.RemotePort", "Invalid operation at current state"
        End If
    End If
    If lngPort < 0 Or lngPort > 65535 Then
        Err.Raise sckInvalidArg, "CSocketMaster.RemotePort", "The argument passed to a function was not in the correct format or in the specified range."
    Else
        m_lngRemotePort = lngPort
    End If
End Property
Private Function ResolveIfHostname(ByVal strHost As String, _
                                   ByVal enmDestination As DestResolucion) As Long
Dim lngAddress       As Long
Dim lngAsynHandle    As Long
Dim lngErrorCode     As Long
Dim blnCancelDisplay As Boolean
    lngAddress = api_inet_addr(strHost)
    If lngAddress = INADDR_NONE Then 'if Host isn't an IP
        ResolveIfHostname = vbNull
        m_enmState = sckResolvingHost
        If AllocateMemory Then
            lngAsynHandle = modSocketMaster.ResolveHost(strHost, m_lngMemoryPointer, ObjPtr(Me))
            If lngAsynHandle = 0 Then
                FreeMemory
                m_enmState = sckError
                lngErrorCode = Err.LastDllError
                blnCancelDisplay = True
                RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ResolveIfHostname", "", 0, blnCancelDisplay)
            Else
                m_colWaitingResolutions.Add enmDestination, "R" & lngAsynHandle
            End If
        Else
            m_enmState = sckError
            Err.Raise sckOutOfMemory, "CSocketMaster.ResolveIfHostname", "Out of memory"
        End If
    Else 'if Host is an IP doen't need to resolve anything
        ResolveIfHostname = lngAddress
    End If
End Function
Private Function ResolveIfHostnameSync(ByVal strHost As String, _
                                       ByRef strHostIP As String, _
                                       ByRef lngErrorCode As Long) As Long
Dim lngPtrToHOSTENT      As Long
Dim udtHostent           As Hostent
Dim lngAddress           As Long
Dim lngPtrToIP           As Long
Dim arrIpAddress(1 To 4) As Byte
Dim Count                As Long
    If strHost = vbNullString Then
        strHostIP = vbNullString
        lngErrorCode = WSAEAFNOSUPPORT
        ResolveIfHostnameSync = vbNull
    Else
        lngAddress = api_inet_addr(strHost)
        If lngAddress = INADDR_NONE Then 'if Host isn't an IP
            lngPtrToHOSTENT = api_gethostbyname(strHost)
            If lngPtrToHOSTENT = 0 Then
                lngErrorCode = Err.LastDllError
                strHostIP = vbNullString
                ResolveIfHostnameSync = vbNull
            Else
                api_CopyMemory udtHostent, ByVal lngPtrToHOSTENT, LenB(udtHostent)
                api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4
                api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4
                api_CopyMemory lngAddress, ByVal lngPtrToIP, 4
                For Count = 1 To 4
                    strHostIP = strHostIP & arrIpAddress(Count) & "."
                Next Count
                strHostIP = Left$(strHostIP, Len(strHostIP) - 1)
                lngErrorCode = 0
                ResolveIfHostnameSync = lngAddress
            End If
        Else 'if Host is an IP doen't need to resolve anything
            lngErrorCode = 0
            strHostIP = strHost
            ResolveIfHostnameSync = lngAddress
        End If
    End If
End Function
Private Sub SendBufferedDataTCP()
Dim arrData()        As Byte
Dim lngBufferLength  As Long
Dim lngResult        As Long
Dim lngTotalSent     As Long
Dim lngErrorCode     As Long
Dim blnCancelDisplay As Boolean
Dim lngTemp          As Long
    Do Until lngResult = SOCKET_ERROR Or Len(m_strSendBuffer) = 0
        lngBufferLength = Len(m_strSendBuffer)
        If lngBufferLength > m_lngSendBufferLen Then
            lngBufferLength = m_lngSendBufferLen
            arrData() = StrConv(Left$(m_strSendBuffer, m_lngSendBufferLen), vbFromUnicode)
        Else
            arrData() = StrConv(m_strSendBuffer, vbFromUnicode)
        End If
        lngResult = api_send(m_lngSocketHandle, arrData(0), lngBufferLength, 0&)
        If lngResult = SOCKET_ERROR Then
            lngErrorCode = Err.LastDllError
            If lngErrorCode = WSAEWOULDBLOCK Then
                If lngTotalSent > 0 Then
                    RaiseEvent SendProgress(lngTotalSent, Len(m_strSendBuffer))
                End If
            Else
                m_enmState = sckError
                blnCancelDisplay = True
                RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SendBufferedData", "", 0, blnCancelDisplay)
            End If
        Else
            lngTotalSent = lngTotalSent + lngResult
            If Len(m_strSendBuffer) > lngResult Then
                m_strSendBuffer = Mid$(m_strSendBuffer, lngResult + 1)
            Else
                m_strSendBuffer = vbNullString
                lngTemp = lngTotalSent
                lngTotalSent = 0
                RaiseEvent SendProgress(lngTemp, 0)
                RaiseEvent SendComplete
            End If
        End If
        DoEvents
    Loop
End Sub
Private Sub SendBufferedDataUDP()
Dim lngAddress       As Long
Dim udtSockAddr      As sockaddr_in
Dim arrData()        As Byte
Dim lngBufferLength  As Long
Dim lngResult        As Long
Dim lngErrorCode     As Long
Dim strTemp          As String
Dim blnCancelDisplay As Boolean
    lngAddress = ResolveIfHostnameSync(m_strRemoteHost, strTemp, lngErrorCode)
    If lngErrorCode <> 0 Then
        m_strSendBuffer = vbNullString
        If lngErrorCode = WSAEAFNOSUPPORT Then
            Err.Raise lngErrorCode, "CSocketMaster.SendBufferedDataUDP", GetErrorDescription(lngErrorCode)
        Else
            Err.Raise sckInvalidArg, "CSocketMaster.SendBufferedDataUDP", "Invalid argument"
        End If
    End If
    With udtSockAddr
        .sin_addr = lngAddress
        .sin_family = AF_INET
        .sin_port = api_htons(modSocketMaster.UnsignedToInteger(m_lngRemotePort))
    End With
    lngBufferLength = Len(m_strSendBuffer)
    arrData() = StrConv(m_strSendBuffer, vbFromUnicode)
    m_strSendBuffer = vbNullString
    lngResult = api_sendto(m_lngSocketHandle, arrData(0), lngBufferLength, 0&, udtSockAddr, LenB(udtSockAddr))
    If lngResult = SOCKET_ERROR Then
        lngErrorCode = Err.LastDllError
        m_enmState = sckError
        blnCancelDisplay = True
        RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SendBufferedDataUDP", "", 0, blnCancelDisplay)
        If Not blnCancelDisplay Then
            MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SendBufferedDataUDP"
        End If
    End If
End Sub
Private Function SocketExists() As Boolean
Dim lngResult        As Long
Dim lngErrorCode     As Long
Dim blnCancelDisplay As Boolean
    SocketExists = True
    If m_lngSocketHandle = INVALID_SOCKET Then
        If m_enmProtocol = sckTCPProtocol Then
            lngResult = api_socket(AF_INET, SOCK_STREAM, IPPROTO_TCP)
        Else
            lngResult = api_socket(AF_INET, SOCK_DGRAM, IPPROTO_UDP)
        End If
        If lngResult = INVALID_SOCKET Then
            m_enmState = sckError
            SocketExists = False
            lngErrorCode = Err.LastDllError
            blnCancelDisplay = True
            RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SocketExists", "", 0, blnCancelDisplay)
        Else
            m_lngSocketHandle = lngResult
            ProcessOptions
            SocketExists = modSocketMaster.RegisterSocket(m_lngSocketHandle, ObjPtr(Me), True)
        End If
    End If
End Function
Public Property Get SocketHandle() As Long
    SocketHandle = m_lngSocketHandle
End Property
Public Property Get State() As SockState
    State = m_enmState
End Property
Public Property Get Tag() As String
    Tag = m_strTag
End Property
Public Property Let Tag(ByVal strTag As String)
    m_strTag = strTag
End Property
''
''Private Function RecvDataToBuffer() As Long
''
''
''Dim arrBuffer()      As Byte
''Dim lngBytesReceived As Long
''Dim strBuffTemporal  As String
''
''Dim lngErrorCode     As Long
''ReDim arrBuffer(m_lngRecvBufferLen - 1) As Byte
''lngBytesReceived = api_recv(m_lngSocketHandle, arrBuffer(0), m_lngRecvBufferLen, 0&)
''If lngBytesReceived = SOCKET_ERROR Then
''m_enmState = sckError
''lngErrorCode = Err.LastDllError
''Err.Raise lngErrorCode, "CSocketMaster.RecvDataToBuffer", GetErrorDescription(lngErrorCode)
''ElseIf lngBytesReceived > 0 Then
''strBuffTemporal = StrConv(arrBuffer(), vbUnicode)
''m_strRecvBuffer = m_strRecvBuffer & Left$(strBuffTemporal, lngBytesReceived)
''RecvDataToBuffer = lngBytesReceived
''End If
''End Function
''
''
''Private Sub SendBufferedData()
''
''
''If m_enmProtocol = sckTCPProtocol Then
''SendBufferedDataTCP
''Else
''SendBufferedDataUDP
''End If
''End Sub
''