csocket.cls

VB做滴邮件收发系统,喜欢的朋友可以下载看看学习参考哈

            '
            'A value of SOCKET_ERROR means that the socket was not created.
            'In this case the SocketExists function must return False
            Exit Function '>---> Bottom
            '
          Else 'NOT M_LNGSOCKETHANDLE...
            '
            'Get default size of the Winsock's buffers.
            Call GetWinsockBuffers  'Modified: 10-MAR-2002
            '
        End If
        '
    End If
    '
    'The m_lngSocketHandle variable contains a valid socket
    'handle value. In this case the function returns True.
    SocketExists = True
    '

End Function

Private Sub GetWinsockBuffers()

  '
  'This subroutine is to retrieve default size of the Winsock buffers.
  'These values will be stored in the module level variables:
  'm_lngSendBufferLen and m_lngRecvBufferLen.
  'It can be called from the SocketExists and Accept functions.
  '
  'Added: 10-MAR-2002
  '

  Dim lngRetValue     As Long 'value returned by the getsockopt Winsock API function
  Dim lngBuffer       As Long 'buffer to pass with the getsockopt call

    '
    If mvarProtocol = sckTCPProtocol Then
        'Buffer for incoming data
        lngRetValue = getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_RCVBUF, lngBuffer, 4&)
        m_lngRecvBufferLen = lngBuffer
        'Buffer for outgoing data
        lngRetValue = getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_SNDBUF, lngBuffer, 4&)
        m_lngSendBufferLen = lngBuffer
      Else 'NOT MVARPROTOCOL...
        'the m_lngMaxMsgSize value is returned by InitWinsockService
        'function from the MSocketSupport module
        m_lngSendBufferLen = m_lngMaxMsgSize
        m_lngRecvBufferLen = m_lngMaxMsgSize
    End If
    '

End Sub

Private Function RecvDataToBuffer() As Long

  '
  'This function is to retrieve data from the Winsock buffer
  'into the class local buffer. The function returns number
  'of bytes retrieved (received).
  '

  Dim lngBytesReceived        As Long     'value returned by recv/recvfrom Winsock API function
  Dim lngRetValue             As Long     'value returned by gethostbyaddr Winsock API function
  Dim strTempBuffer           As String   'just a temporary buffer
  Dim arrBuffer()             As Byte     'buffer to pass to the recv/recvfrom Winsock API function
  Dim udtSockAddr             As sockaddr_in 'socket address of the remote peer
  Dim lngSockAddrLen          As Long     'size of the sockaddr_in structure
  Dim udtHostEnt              As HostEnt  'used to get host name with gethostbyaddr function

    '
    'Prepare the buffer to pass it to the recv/recvfrom Winsock API function.
    'The m_lngRecvBufferLen variable was initialized during creating
    'of the socket, see the vbSocket function to find out how.
    ReDim arrBuffer(m_lngRecvBufferLen - 1)
    '
    If mvarProtocol = sckTCPProtocol Then
        '
        'If the socket is a connection-oriented one, just call the recv function
        'to retrieve all the arrived data from the Winsock buffer.
        lngBytesReceived = recv(m_lngSocketHandle, arrBuffer(0), m_lngRecvBufferLen, 0&)
        '
      Else 'NOT MVARPROTOCOL...
        '
        'If the socket uses UDP, it's another story. As stated in the MS Winsock Control
        'documentation after receiving data the RemoteHost, RemoteHostIP, and RemotePort
        'properties contains parameters of the machine sending the UDP data. To achive
        'such a behavior we must use the recvfrom Winsock API function.
        '
        lngSockAddrLen = Len(udtSockAddr)
        '
        lngBytesReceived = recvfrom(m_lngSocketHandle, arrBuffer(0), m_lngRecvBufferLen, _
                           0&, udtSockAddr, lngSockAddrLen)
        '
        If Not lngBytesReceived = SOCKET_ERROR Then
            '
            'Now the udtSockAddr contains a socket address of the remote host.
            'Initialize the RemoteHost, RemoteHostIP, and RemotePort properties.
            '
            With udtSockAddr
                '
                'RemotePort property
                m_lngRemotePort = IntegerToUnsigned(ntohs(.sin_port))
                'RemoteHostIP property
                m_strRemoteHostIP = StringFromPointer(inet_ntoa(.sin_addr))
                'RemoteHost property
                lngRetValue = gethostbyaddr(.sin_addr, 4&, AF_INET)
                CopyMemory udtHostEnt, ByVal lngRetValue, Len(udtHostEnt)
                m_strRemoteHost = StringFromPointer(udtHostEnt.hName)
                '
            End With 'UDTSOCKADDR
            '
        End If
        '
    End If
    '
    If lngBytesReceived > 0 Then
        '
        'Convert a byte array into the VB string
        strTempBuffer = StrConv(arrBuffer(), vbUnicode)
        'Store received data in the local buffer for incoming data - m_strRecvBuffer
        m_strRecvBuffer = m_strRecvBuffer & Left$(strTempBuffer, lngBytesReceived)
        'Return number of received bytes.
        RecvDataToBuffer = lngBytesReceived
        '
      ElseIf lngBytesReceived = SOCKET_ERROR Then 'NOT LNGBYTESRECEIVED...
        '
        Err.Raise Err.LastDllError, "CSocket.RecvToBuffer", GetErrorDescription(Err.LastDllError)
        '
    End If
    '

End Function

Private Function RecvData(varData As Variant, blnPeek As Boolean, Optional varType As Variant, Optional maxLen As Variant) As Long

  '
  'This function is to retrieve data from the local buffer (m_strRecvBuffer).
  'It can be called by two public methods of the class - GetData and PeekData.
  'Behavior of the function is defined by the blnPeek argument. If a value of
  'that argument is True, the function returns number of bytes in the
  'local buffer, and copy data from that buffer into the varData argument.
  'If a value of the blnPeek is False, then this function returns number of
  'bytes received, and move data from the local buffer into the varData
  'argument. MOVE means that data will be removed from the local buffer.
  '

  Dim strRecvData As String   'temporary string buffer
  Dim arrBuffer() As Byte     'temporary byte array buffer

    '
    'If the local buffer is empty, go away - we have nothing to do here.
    If Len(m_strRecvBuffer) = 0 Then Exit Function ':(燛xpand Structure or consider reversing Condition
    '
    If IsEmpty(maxLen) Then
        maxLen = 0
    End If
    '
    If (Not maxLen > Len(m_strRecvBuffer)) And (maxLen > 0) Then
        '
        strRecvData = Left$(m_strRecvBuffer, CLng(maxLen))
        '
        If Not blnPeek Then
            m_strRecvBuffer = Mid$(m_strRecvBuffer, CLng(maxLen + 1))
        End If
        '
        arrBuffer() = StrConv(strRecvData, vbFromUnicode)
        '
      Else 'NOT (NOT...
        '
        arrBuffer() = StrConv(m_strRecvBuffer, vbFromUnicode)
        '
        If Not blnPeek Then
            m_strRecvBuffer = ""
        End If
        '
    End If
    '
    If IsEmpty(varType) Then
        varData = CStr(StrConv(arrBuffer(), vbUnicode))
      Else 'ISEMPTY(VARTYPE) = FALSE
        '
        Select Case varType
          Case vbArray + vbByte
            'Modified 28-MAY-2002. Thanks to Michael Freidgeim
            '--------------------------------
            'Dim strArray As String
            'strArray = StrConv(arrBuffer(), vbUnicode)
            'varData = StrConv(strArray, vbFromUnicode)
            varData = arrBuffer()
            '--------------------------------
          Case vbBoolean
  Dim blnData As Boolean ':(燤ove line to top of current Function
            CopyMemory blnData, arrBuffer(0), LenB(blnData)
            varData = blnData
          Case vbByte
  Dim bytData As Byte ':(燤ove line to top of current Function
            CopyMemory bytData, arrBuffer(0), LenB(bytData)
            varData = bytData
          Case vbCurrency
  Dim curData As Currency ':(燤ove line to top of current Function
            CopyMemory curData, arrBuffer(0), LenB(curData)
            varData = curData
          Case vbDate
  Dim datData As Date ':(燤ove line to top of current Function
            CopyMemory datData, arrBuffer(0), LenB(datData)
            varData = datData
          Case vbDouble
  Dim dblData As Double ':(燤ove line to top of current Function
            CopyMemory dblData, arrBuffer(0), LenB(dblData)
            varData = dblData
          Case vbInteger
  Dim intData As Integer ':(燤ove line to top of current Function
            CopyMemory intData, arrBuffer(0), LenB(intData)
            varData = intData
          Case vbLong
  Dim lngData As Long ':(燤ove line to top of current Function
            CopyMemory lngData, arrBuffer(0), LenB(lngData)
            varData = lngData
          Case vbSingle
  Dim sngData As Single ':(燤ove line to top of current Function
            CopyMemory sngData, arrBuffer(0), LenB(sngData)
            varData = sngData
          Case vbString
  Dim strData As String ':(燤ove line to top of current Function
            strData = StrConv(arrBuffer(), vbUnicode)
            varData = strData
            '
        End Select
        '
    End If
    '
    'Added 28-MAY-2002. Thanks to Michael Freidgeim
    m_lngBytesReceived = Len(m_strRecvBuffer) 'reset BytesReceived after Getdata
    '

End Function

Private Sub DestroySocket()

  '
  'The purpose of this subroutine is to unregister the socket with
  'UnregisterSocket that can be found in the MSocketSupport module
  'and close the socket with the closesocket Winsock API function.
  '

  Dim lngRetValue As Long 'value returned by the closesocket

    'Winsock AP function
    '
    If Not m_lngSocketHandle = INVALID_SOCKET Then
        '
        'Unregister the socket. For more info on how it works
        'see the code of the function in the MSocketSupport module
        Call MSocketSupport.UnregisterSocket(m_lngSocketHandle)
        '
        'Close the socket with the closesocket Winsock API function.
        lngRetValue = api_closesocket(m_lngSocketHandle)
        '

        '
        If lngRetValue = SOCKET_ERROR Then
            Err.Raise Err.LastDllError, "CSocket.DestroySocket", GetErrorDescription(Err.LastDllError)
        End If
        '
        'Change the SocketHandle property value
        m_lngSocketHandle = INVALID_SOCKET
        '
        'If the bind Winsock API function has been called on
        'this socket, m_blnSocketIsBound = True. We need to
        'change this value.
        m_blnSocketIsBound = False  'Added: 10-MAR-2002
        '
    End If
    '

End Sub

Private Sub Class_Terminate()

  '

    If Not m_lngSocketHandle = INVALID_SOCKET Then
        Call DestroySocket
    End If
    '
    Call CleanupWinsock
    '

End Sub

Private Sub SendBufferedData()

  '
  'This procedure sends data from the local buffer (m_strSendBuffer).
  'The data from the client application is passed with the SendData
  'method of the class as an argument and is stored in the local
  'buffer until all the data from that buffer will be sent using this
  'subroutine.
  '
  'Why do we need to store data in the local buffer? There are some
  'things happenning in the Winsock's buffer for outgoing data since
  'we're using non-blocking sockets' calls. If that buffer is full,
  'the transport subsystem doesn't take the data and the send/sendto
  'functions return a value of SOCKET_ERROR, Err.LastDllError give
  'us a value of WSAEWOULDBLOCK. This means that if the socket would
  'be a blocking one, such a call would block socket until the buffer
  'will be freed and ready to accept some data to send.
  '
  'So this procedure can be called several (mostly not more than two)
  'times for the same chunk of data. First call is in the body of the
  'SendData method, and other calls (if necessary) will be performed
  'from the PostSocketEvent subroutine, as soon as the FD_WRITE message
  'will be received. The arrival of the FD_WRITE message means that a
  'socket is in a write-able state - its buffer is ready to get data.
  '

  Dim lngRetValue     As Long         'value returned by send/sendto Winsock API function
  Dim arrData()       As Byte         'data to send with the send/sendto function
  Dim lngBufferLength As Long         'size of the data buffer to send
  Dim udtSockAddr     As sockaddr_in  'address of the remote socket - for the sendto function

    '
    'The send/sendto function needs this value for one of its arguments
    lngBufferLength = Len(m_strSendBuffer)
    '
    'Convert data from a VB string to a byte array
    arrData() = StrConv(m_strSendBuffer, vbFromUnicode)
    '
    If mvarProtocol = sckTCPProtocol Then
        '
        'just call the send function in order to send data via connection
        lngRetValue = send(m_lngSocketHandle, arrData(0), lngBufferLength, 0&)
        '
      Else 'NOT MVARPROTOCOL...
        '
        'With UDP socket we are going to use the sendto Winsock API function.
        'This function needs the socket address of the remote host to send
        'message to.
        '
        If Len(m_strRemoteHostIP) = 0 Then
            '
            'If the RemoteHostIP property is empty, we don't know
            'the remote IP so we need to resolve that address.
            '
            m_varInternalState = istSendingDatagram
            m_lngRequestID = MSocketSupport.ResolveHost(m_strRemoteHost, ObjPtr(Me))
            '
            'The ResolveHost is an asynchronous call. This subroutine wiil be called
            'one more time from the PostGetHostEvent procedure when the host will be
            'resolved.
            '
          Else 'NOT LEN(M_STRREMOTEHOSTIP)...
            '
            'If we are here the host was resolved successfully and the RemoteHostIP
            'property provides us with IP to send a UDP message to.
            '
            'Build the sockaddr_in structure to pass the remote socket address
            'to the sendto function.
            With udtSockAddr
                .sin_addr = inet_addr(m_strRemoteHostIP)
                .sin_port = htons(UnsignedToInteger(m_lngRemotePort))
                .sin_family = AF_INET
            End With 'UDTSOCKADDR
            '
            'Call the sendto function in order to send a UDP message
            lngRetValue = sendto(m_lngSocketHandle, arrData(0), lngBufferLength, 0&, udtSockAddr, Len(udtSockAddr))
            '
        End If
        '
    End If
    '
    If lngRetValue = SOCKET_ERROR Then
        '
        'If a value of Err.LastDllError is WSAEWOULDBLOCK, that means
        'that the Winsock's buffer for outgoing data is full and cannot
        'accept data to send. In this case we ignore this error and do
        'not empty local buffer (m_strSendBuffer).
        '
        If Not Err.LastDllError = WSAEWOULDBLOCK Then
            Err.Raise Err.LastDllError, "CSocket.SendData", GetErrorDescription(Err.LastDllError)

        End If
        '
      Else 'NOT LNGRETVALUE...
        '
        'The data were sent successfully. Raise the OnSendProgress or
        'OnSendComplete event to let the client app know.
        '

        '
        If Len(m_strSendBuffer) > lngRetValue Then
            '
            m_strSendBuffer = Mid$(m_strSendBuffer, lngRetValue + 1)
            '
          Else 'NOT LEN(M_STRSENDBUFFER)...
            m_strSendBuffer = ""

            RaiseEvent OnSendComplete
        End If
        '
        RaiseEvent OnSendProgress(lngRetValue, Len(m_strSendBuffer))
        '
    End If
    '

End Sub