Planet Source Code Jumbo …e CD Visual Basic 1 to 7/5_2007-2008.ISO/data/Zips/A_Complete2049172212007.psc/CSocket.cls

Text File | 2006-11-22 | 21KB | 540 lines

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
'********************************************************************************
'CSocket class
'Copyright ⌐ 2002 by Oleg Gdalevich
'Visual Basic Internet Programming website (http://www.vbip.com)
'********************************************************************************
'To use this class module you need:
'   MSocketSupport code module
'********************************************************************************
'Version: 1.0.12     Modified: 17-OCT-2002
'********************************************************************************
'To get latest version of this code please visit the following web page:
'http://www.vbip.com/winsock-api/csocket-class/csocket-class-01.asp
'********************************************************************************
Option Explicit
'
'Added: 23-AUG-2002
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lparam As Long) As Long
'
'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
'
Private m_blnSendFlag As Boolean        'Added: 12-SEP-2002
'
'This flag variable indicates that the SO_BROADCAST option
'is set on the socket
Private m_blnBroadcast      As Boolean  'Added: 09-JULY-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
    'length of the data to send - needed to call the send(sendto) Winsock API function
    Dim lngBufferLength As Long
    '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
    '
    On Error Resume Next
    '
    '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 Exit Sub
        '
    Else
        '
        '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
        '
    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
            blnData = CBool(varData)
            ReDim arrData(LenB(blnData) - 1)
            CopyMemory arrData(0), blnData, LenB(blnData)
        Case vbByte
            Dim bytData As Byte
            bytData = CByte(varData)
            ReDim arrData(LenB(bytData) - 1)
            CopyMemory arrData(0), bytData, LenB(bytData)
        Case vbCurrency
            Dim curData As Currency
            curData = CCur(varData)
            ReDim arrData(LenB(curData) - 1)
            CopyMemory arrData(0), curData, LenB(curData)
        Case vbDate
            Dim datData As Date
            datData = CDate(varData)
            ReDim arrData(LenB(datData) - 1)
            CopyMemory arrData(0), datData, LenB(datData)
        Case vbDouble
            Dim dblData As Double
            dblData = CDbl(varData)
            ReDim arrData(LenB(dblData) - 1)
            CopyMemory arrData(0), dblData, LenB(dblData)
        Case vbInteger
            Dim intData As Integer
            intData = CInt(varData)
            ReDim arrData(LenB(intData) - 1)
            CopyMemory arrData(0), intData, LenB(intData)
        Case vbLong
            Dim lngData As Long
            lngData = CLng(varData)
            ReDim arrData(LenB(lngData) - 1)
            CopyMemory arrData(0), lngData, LenB(lngData)
        Case vbSingle
            Dim sngData As Single
            sngData = CSng(varData)
            ReDim arrData(LenB(sngData) - 1)
            CopyMemory arrData(0), sngData, LenB(sngData)
        Case vbString
            Dim strData As String
            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.
    m_blnSendFlag = True
    Call SendBufferedData
    '
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 Resume Next
    '
    '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))
    '
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 Resume Next
    '
    '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
    '
    '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
    Else
        mvarState = sckListening
    End If
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 Resume Next
    '
    '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))
    '
End Sub


Public Sub Connect(Optional strRemoteHost As Variant, Optional lngRemotePort As Variant)
Attribute Connect.VB_Description = "Connect to the remote computer"
    '
    Dim lngHostAddress  As Long         '32 bit host address
    Dim udtAddress      As sockaddr_in  'socket address - used by the connect Winsock API function
    Dim lngRetValue     As Long         'value returned by the connect Winsock API function
    '
    On Error Resume Next
    '
    'If no socket has been created before, try to create a new one
    If Not SocketExists Then Exit Sub
    '
    '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
    '
    '----------------------------------------------------------
    'Added: 31-JUL-2002
    '----------------------------------------------------------
    If Len(m_strRemoteHost) = 0 Then Exit Sub
    '----------------------------------------------------------
    '
    m_varInternalState = istConnecting
    '
    '------------------------------------------------------------------
    'Modified: 08-JULY-2002
    '------------------------------------------------------------------
    'Here is a major change. Since version 1.0.6 (08-JULY-2002) the
    'SCocket class doesn't try to resolve the IP address into a
    'domain name while connecting.
    '------------------------------------------------------------------
    '
    'Try to get 32 bit host address from the RemoteHost property value
    lngHostAddress = inet_addr(m_strRemoteHost)
    '
    If lngHostAddress = INADDR_NONE Then
        '
        'The RemoteHost property doesn't contain a valid IP address string,
        'so that is perhaps a domain name string that we need to resolve
        'into IP address
        '
        'The ResolveHost function, that can be found in the MSocketSupport
        'module, will call the WSAAsyncGetHostByName Winsock API function.
        'That function is an asynchronous one, so code in this class will be executing
        'after the call to the PostGetHostEvent procedure from the WindowProc function
        'in the MSupportSocket.
        '
        'Also, as you can see, the second argument is a pointer to the object, that is
        'this instance of the CSocket class. We need this because the callback function
        'has to know to which object send the received host infromation. See the code
        'in the MSocketSupport module for more information.
        '
        'Change the State property value
        mvarState = sckResolvingHost
        'Debug.Print "mvarState = sckResolvingHost"
        '
        m_lngRequestID = 0
        m_lngRequestID = MSocketSupport.ResolveHost(m_strRemoteHost, ObjPtr(Me))
        '
        '-------------------------------------------------------
        'Added: 04-JUNE-2002
        '-------------------------------------------------------
        If m_lngRequestID = 0 Then Call DestroySocket
        '-------------------------------------------------------
        '
    Else
        '
        'The RemoteHost property contains a valid IP address string,
        'so we can go on connecting to the remote host.
        '
        'Build the sockaddr_in structure to pass it to the connect
        'Winsock API function as an address of the remote host.
        With udtAddress
            '
            .sin_addr = lngHostAddress
            .sin_family = AF_INET
            .sin_port = htons(UnsignedToInteger(CLng(m_lngRemotePort)))
            '
        End With
        '
        'Call the connect Winsock API function in order to establish connection.
        lngRetValue = api_connect(m_lngSocketHandle, udtAddress, Len(udtAddress))
        '
        'Since the socket we use is a non-blocking one, the connect Winsock API
        'function should return a value of SOCKET_ERROR anyway.
        '
        If lngRetValue = SOCKET_ERROR Then
            '
            'The WSAEWOULDBLOCK error is OK for such a socket
            '
            If Not Err.LastDllError = WSAEWOULDBLOCK Then
                '
            Else
                'Change the State property value
                mvarState = sckConnecting
            End If
            '
        End If
        '
    End If
End Sub

Public Sub CloseSocket()
Attribute CloseSocket.VB_Description = "Close current connection"
    '
    Dim lngRetValue As Long 'value returned by the shutdown Winsock API function
    '
    On Error Resume Next
    '
    'Why do we need to run the code that should not be running?
    If m_lngSocketHandle = INVALID_SOCKET Then Exit Sub
    '
    If Not mvarState = sckConnected Then
        '
        'If the socket is not connected we can just close it
        Call DestroySocket
        mvarState = sckClosed
        '
    Else
        '
        'If the socket is connected, it's another story.
        'In order to be sure that no data will be lost the
        'graceful shutdown of the socket should be performed.
        '
        mvarState = sckClosing
        '
        'Call the shutdown Winsock API function in order to
        'close the connection. That doesn't mean that the
        'connection will be closed after the call of the
        'shutdown function. Connection will be closed from
        'the PostSocketEvent subroutine when the FD_CLOSE
        'message will be received.
        '
        'For people who know what the FIN segment in the
        'TCP header is - this function sends an empty packet
        'with the FIN bit turned on.
        '
        lngRetValue = shutdown(m_lngSocketHandle, SD_SEND)
        '
    End If
End Sub

Public Sub Bind(Optional lngLocalPort As Long, Optional strLocalIP As String)
Attribute Bind.VB_Description = "Binds socket to specific port and adapter"
    '
    Dim lngRetValue     As Long         'value returned by the bind Winsock API function
    Dim udtLocalAddr    As sockaddr_in  'local socket address to bind to - used by the
    '                                    bind Winsock API function
    Dim lngAddress      As Long         '32-bit host address - value returned by
    '                                    the inet_addr Winsock API function
    '
    On Error Resume Next
    '
    'If no socket has been created before, try to create a new one
    If Not SocketExists Then Exit Sub
    '
    'If the arguments of this function are not missing, they
    'overwrites values of the RemoteHost and RemotePort properties.
    '
    If Len(strLocalIP) > 0 Then
        m_strLocalIP = strLocalIP
    End If
    '
    If lngLocalPort > 0 Then
        m_lngLocalPort = lngLocalPort
    End If
    '
    If Len(m_strLocalIP) > 0 Then
        '
        'If the local IP is known, get the address
        'from it with the inet_addr Winsock API function.
        lngAddress = inet_addr(m_strLocalIP)
        '
    Else
        '
        'If the IP is unknown, assign the default interface's IP.
        'Actually, this line is useless in Visual Basic code,
        'as INADDR_ANY = 0 (IP = 0.0.0.0).
        lngAddress = INADDR_ANY
        '
    End If
    '
    If lngAddress = SOCKET_ERROR Then
        '
        'Bad address - go away
        Exit Sub
        '
    End If
    '
    'Prepare the udtLocalAddr UDT that is a socket address structure.
    With udtLocalAddr
        '
        'host address (32-bits value)
        .sin_addr = lngAddress
        'address family
        .sin_family = AF_INET
        'port number in the network