csocket.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CSocket"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

Option Explicit
'
'The CSocket protocol's constants as for
'the MS Winsock Control interface
Public Enum ProtocolConstants
    sckTCPProtocol = 0
    sckUDPProtocol = 1
End Enum
'
'The CSocket error's constants as for
'the MS Winsock Control interface
Public Enum ErrorConstants
    sckAddressInUse = 10048
    sckAddressNotAvailable = 10049
    sckAlreadyComplete = 10037
    sckAlreadyConnected = 10056
    sckBadState = 40006
    sckConnectAborted = 10053
    sckConnectionRefused = 10061
    sckConnectionReset = 10054
    sckGetNotSupported = 394
    sckHostNotFound = 11001
    sckHostNotFoundTryAgain = 11002
    sckInProgress = 10036
    sckInvalidArg = 40014
    sckInvalidArgument = 10014
    sckInvalidOp = 40020
    sckInvalidPropertyValue = 380
    sckMsgTooBig = 10040
    sckNetReset = 10052
    sckNetworkSubsystemFailed = 10050
    sckNetworkUnreachable = 10051
    sckNoBufferSpace = 10055
    sckNoData = 11004
    sckNonRecoverableError = 11003
    sckNotConnected = 10057
    sckNotInitialized = 10093
    sckNotSocket = 10038
    sckOpCanceled = 10004
    sckOutOfMemory = 7
    sckOutOfRange = 40021
    sckPortNotSupported = 10043
    sckSetNotSupported = 383
    sckSocketShutdown = 10058
    sckSuccess = 40017
    sckTimedout = 10060
    sckUnsupported = 40018
    sckWouldBlock = 10035
    sckWrongProtocol = 40026
End Enum
'
'The CSocket state's constants as for
'the MS Winsock Control interface
Public Enum StateConstants
    sckClosed = 0
    sckOpen
    sckListening
    sckConnectionPending
    sckResolvingHost
    sckHostResolved
    sckConnecting
    sckConnected
    sckClosing
    sckError
End Enum
'
'In order to resolve a host name the MSocketSupport.ResolveHost
'function can be called from the Connect and SendData methods
'of this class. The callback acceptor for that routine is the
'PostGetHostEvent procedure. This procedure determines what to
'do next with the received host's address checking a value of
'the m_varInternalState variable.
Private Enum InternalStateConstants
    istConnecting
    istSendingDatagram
End Enum
'
Private m_varInternalState As InternalStateConstants
'
'Local (module level) variables to hold values of the
'properties of this (CSocket) class.
Private mvarProtocol        As ProtocolConstants
Private mvarState           As StateConstants
Private m_lngBytesReceived  As Long
Private m_strLocalHostName  As String
Private m_strLocalIP        As String
Private m_lngLocalPort      As Long
Private m_strRemoteHost     As String
Private m_strRemoteHostIP   As String
Private m_lngRemotePort     As Long
Private m_lngSocketHandle   As Long
'
'Resolving host names is performed in an asynchronous mode,
'the m_lngRequestID variable just holds the value returned
'by the ResolveHost function from the MSocketSupport module.
Private m_lngRequestID      As Long
'
'Internal (for this class) buffers. They are the VB Strings.
'Don't trust that guy who told that the VB String data type
'cannot properly deal with binary data. Actually, it can, and
'moreover you have a lot of means to deal with that data -
'the VB string functions (such as Left, Mid, InStr and so on).
'If you need to get a byte array from a string, just call the
'StrConv function:
'
'byteArray() = StrConv(strBuffer, vbFromUnicode)
'
Private m_strSendBuffer     As String 'The internal buffer for outgoing data
Private m_strRecvBuffer     As String 'The internal buffer for incoming data
'
'Lenght of the Winsock buffers. By default = 8192 bytes for TCP sockets.
'These values are initialized in the SocketExists function.
'Now, I really don't know why I was in need to get these values.
Private m_lngSendBufferLen  As Long
Private m_lngRecvBufferLen  As Long
'
'Maximum size of a datagram that can be sent through
'a message-oriented (UDP) socket. This value is returned
'by the InitWinsock function from the MSocketSupport module.
Private m_lngMaxMsgSize     As Long
'
'This flag variable indicates that the socket is bound to
'some local socket address
Private m_blnSocketIsBound  As Boolean  'Added: 10-MAR-2002
'
'These are those MS Winsock's events.
'Pay attention that the "On" prefix is added.
Public Event OnClose()
Attribute OnClose.VB_Description = "Occurs when the connection has been closed"
Public Event OnConnect()
Attribute OnConnect.VB_Description = "Occurs connect operation is completed"
Public Event OnConnectionRequest(ByVal requestID As Long)
Public Event OnDataArrival(ByVal bytesTotal As Long)
Public Event OnError(ByVal Number As Integer, Description As String, ByVal sCode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Public Event OnSendComplete()
Public Event OnSendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long)

Public Sub SendData(varData As Variant)
Attribute SendData.VB_Description = "Send data to remote computer"

  '
  'data to send - will be built from the varData argument

  Dim arrData()       As Byte

    'value returned by the send(sendto) Winsock API function
  Dim lngRetValue     As Long ':(燤ove line to top of current Sub
    'length of the data to send - needed to call the send(sendto) Winsock API function
  Dim lngBufferLength As Long ':(燤ove line to top of current Sub
    'this strucure just contains address of the remote socket to send data to;
    'only for UDP sockets when the sendto Winsock API function is used
  Dim udtSockAddr     As sockaddr_in ':(燤ove line to top of current Sub
    '
    On Error GoTo SendData_Err_Handler
    '
    'If a connection-oriented (TCP) socket was not created or connected to the
    'remote host before calling the SendData method, the MS Winsock Control
    'raises the sckBadState error.
    If mvarProtocol = sckTCPProtocol Then
        '
        If m_lngSocketHandle = INVALID_SOCKET Then
            Err.Raise sckBadState, "CSocket.SendData", _
                      "Wrong protocol or connection state for the requested transaction or request."
            Exit Sub '>---> Bottom
        End If
        '
      Else 'NOT MVARPROTOCOL...
        '
        'If the socket is a message-oriented one (UDP), this is OK to create
        'it with the call of the SendData method. The SocketExists function
        'creates a new socket.
        If Not SocketExists Then Exit Sub ':(燛xpand Structure or consider reversing Condition
        '
    End If
    '
    Select Case varType(varData)
      Case vbArray + vbByte
        'Modified 28-MAY-2002. Thanks to Michael Freidgeim
        '--------------------------------
        'Dim strArray As String
        'strArray = CStr(varData)
        arrData() = varData
        '--------------------------------
      Case vbBoolean
  Dim blnData As Boolean ':(燤ove line to top of current Sub
        blnData = CBool(varData)
        ReDim arrData(LenB(blnData) - 1)
        CopyMemory arrData(0), blnData, LenB(blnData)
      Case vbByte
  Dim bytData As Byte ':(燤ove line to top of current Sub
        bytData = CByte(varData)
        ReDim arrData(LenB(bytData) - 1)
        CopyMemory arrData(0), bytData, LenB(bytData)
      Case vbCurrency
  Dim curData As Currency ':(燤ove line to top of current Sub
        curData = CCur(varData)
        ReDim arrData(LenB(curData) - 1)
        CopyMemory arrData(0), curData, LenB(curData)
      Case vbDate
  Dim datData As Date ':(燤ove line to top of current Sub
        datData = CDate(varData)
        ReDim arrData(LenB(datData) - 1)
        CopyMemory arrData(0), datData, LenB(datData)
      Case vbDouble
  Dim dblData As Double ':(燤ove line to top of current Sub
        dblData = CDbl(varData)
        ReDim arrData(LenB(dblData) - 1)
        CopyMemory arrData(0), dblData, LenB(dblData)
      Case vbInteger
  Dim intData As Integer ':(燤ove line to top of current Sub
        intData = CInt(varData)
        ReDim arrData(LenB(intData) - 1)
        CopyMemory arrData(0), intData, LenB(intData)
      Case vbLong
  Dim lngData As Long ':(燤ove line to top of current Sub
        lngData = CLng(varData)
        ReDim arrData(LenB(lngData) - 1)
        CopyMemory arrData(0), lngData, LenB(lngData)
      Case vbSingle
  Dim sngData As Single ':(燤ove line to top of current Sub
        sngData = CSng(varData)
        ReDim arrData(LenB(sngData) - 1)
        CopyMemory arrData(0), sngData, LenB(sngData)
      Case vbString
  Dim strData As String ':(燤ove line to top of current Sub
        strData = CStr(varData)
        ReDim arrData(Len(strData) - 1)
        arrData() = StrConv(strData, vbFromUnicode)
      Case Else
        '
        'Unknown data type
        '
    End Select
    '
    'Store all the data to send in the module level
    'variable m_strSendBuffer.
    m_strSendBuffer = StrConv(arrData(), vbUnicode)
    '
    'Call the SendBufferedData subroutine in order to send the data.
    'The SendBufferedData sub is just a common procedure that is
    'called from different places in this class.
    'Nothing special - just the code reuse.
    Call SendBufferedData
    '
EXIT_LABEL:
    '

Exit Sub

    '
SendData_Err_Handler:
    '
    If Err.LastDllError = WSAENOTSOCK Then
        Err.Raise sckBadState, "CSocket.SendData", "Wrong protocol or connection state for the requested transaction or request."
      Else 'NOT ERR.LASTDLLERROR...
        Err.Raise Err.Number, "CSocket.SendData", Err.Description
    End If
    '
    GoTo EXIT_LABEL
    '

End Sub

Public Sub PeekData(varData As Variant, Optional varType As Variant, Optional maxLen As Variant)
Attribute PeekData.VB_Description = "Look at incoming data without removing it from the buffer"

  '

  Dim lngBytesReceived As Long    'value returned by the RecvData function

    '
    On Error GoTo PeekData_Err_Handler
    '
    'The RecvData is a universal subroutine that can either to retrieve or peek
    'data from the Winsock buffer. If a value of the second argument (blnPeek As Boolean)
    'of the RecvData subroutine is True, it will be just peeking.
    lngBytesReceived = RecvData(varData, True, IIf(IsMissing(varType), Empty, varType), _
                       IIf(IsMissing(maxLen), Empty, maxLen))
    '
EXIT_LABEL:
    '

Exit Sub

    '
PeekData_Err_Handler:
    '
    Err.Raise Err.Number, "CSocket.PeekData", Err.Description
    '
    GoTo EXIT_LABEL
    '

End Sub

Public Sub Listen()
Attribute Listen.VB_Description = "Listen for incoming connection requests"

  '

  Dim lngRetValue As Long 'value returned by the listen Winsock API function

    '
    On Error GoTo Listen_Err_Handler
    '
    'SocketExists is not a variable. It is a function that can
    'create a socket, if the class has no one.
    If Not SocketExists Then Exit Sub ':(燛xpand Structure or consider reversing Condition
    '
    'The listen Winsock API function cannot be called
    'without the call of the bind one.
    If Not m_blnSocketIsBound Then  'Added: 10-MAR-2002
        Call Bind
    End If                          'Added: 10-MAR-2002
    '
    'Turn the socket into a listening state
    lngRetValue = api_listen(m_lngSocketHandle, 5&)
    '
    If lngRetValue = SOCKET_ERROR Then
        mvarState = sckError

        Err.Raise Err.LastDllError, "CSocket.Listen", GetErrorDescription(Err.LastDllError)
      Else 'NOT LNGRETVALUE...
        mvarState = sckListening

    End If
    '
EXIT_LABEL:
    '

Exit Sub

    '
Listen_Err_Handler:
    '
    Err.Raise Err.Number, "CSocket.Listen", Err.Description
    '
    GoTo EXIT_LABEL
    '

End Sub

Public Sub GetData(varData As Variant, Optional varType As Variant, Optional maxLen As Variant)
Attribute GetData.VB_Description = "Retrieve data sent by the remote computer"

  '

  Dim lngBytesReceived As Long    'value returned by the RecvData function

    '
    On Error GoTo GetData_Err_Handler
    '
    'A value of the second argument of the RecvData subroutine is False, so in this way
    'this procedure will retrieve incoming data from the buffer.
    lngBytesReceived = RecvData(varData, False, IIf(IsMissing(varType), Empty, varType), _
                       IIf(IsMissing(maxLen), Empty, maxLen))
    '
EXIT_LABEL:
    '

Exit Sub

    '
GetData_Err_Handler:
    '
    Err.Raise Err.Number, "CSocket.GetData", Err.Description
    '
    GoTo EXIT_LABEL
    '

End Sub

Public Sub Connect(Optional strRemoteHost As Variant, Optional lngRemotePort As Variant)
Attribute Connect.VB_Description = "Connect to the remote computer"

  '

    On Error GoTo Connect_Err_Handler
    '
    'If no socket has been created before, try to create a new one
    If Not SocketExists Then Exit Sub ':(燛xpand Structure or consider reversing Condition
    '
    'If the arguments of this function are not missing, they
    'overwrite values of the RemoteHost and RemotePort properties.
    '
    If Not IsMissing(strRemoteHost) Then    'Added: 04-MAR-2002
        If Len(strRemoteHost) > 0 Then
            m_strRemoteHost = CStr(strRemoteHost)
        End If
    End If                                  'Added: 04-MAR-2002
    '
    If Not IsMissing(lngRemotePort) Then    'Added: 04-MAR-2002
        If IsNumeric(lngRemotePort) Then    'Added: 04-MAR-2002
            m_lngRemotePort = CLng(lngRemotePort)
        End If                              'Added: 04-MAR-2002
    End If                                  'Added: 04-MAR-2002
    '