csocketmaster.cls

用VB编写的一个小程序

    
    m_enmState = sckHostResolved: If ShowDebug Then Debug.Print "STATE: sckHostResolved"
    
    Dim udtHostent As HOSTENT
    Dim lngPtrToIP As Long
    Dim arrIpAddress(1 To 4) As Byte
    Dim lngRemoteHostAddress As Long
    Dim Count As Integer
    Dim strIpAddress As String
    
    api_CopyMemory udtHostent, ByVal m_lngMemoryPointer, LenB(udtHostent)
    api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4
    api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4
    api_CopyMemory lngRemoteHostAddress, ByVal lngPtrToIP, 4
    
    'free memmory, won't need it any longer
    FreeMemory
    
    'We turn the 32 bits long into a readable string.
    'Note: we don't need this string. I put this here just
    'in case you need it.
    For Count = 1 To 4
        strIpAddress = strIpAddress & arrIpAddress(Count) & "."
    Next
        
    strIpAddress = Left$(strIpAddress, Len(strIpAddress) - 1)
    
    'Decide what to do with the result according to the destination
    Select Case enmDestination
    
    Case destConnect
        ConnectToIP lngRemoteHostAddress, 0
    
    End Select

Else 'there were errors trying to resolve the hostname

    'free buffer memory
    FreeMemory
    
    Select Case enmDestination
        
    Case destConnect
        ConnectToIP vbNull, lngErrorCode
        
    End Select

End If
End Sub

'This procedure is called by the WindowProc callback function
'from the modSocketMaster module. The lngEventID argument is an
'ID of the network event occurred for the socket. The lngErrorCode
'argument contains an error code only if an error was occurred
'during an asynchronous execution.
Private Sub PostSocket(ByVal lngEventID As Long, ByVal lngErrorCode As Long)

'handle any possible error
If lngErrorCode <> 0 Then
    m_enmState = sckError: If ShowDebug Then Debug.Print "STATE: sckError"
    Dim blnCancelDisplay As Boolean
    blnCancelDisplay = True
    RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.PostSocket", "", 0, blnCancelDisplay)
    If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.PostSocket"
    Exit Sub
End If

Dim udtSockAddr As sockaddr_in
Dim lngResult As Long
Dim lngBytesReceived As Long

Select Case lngEventID

'======================================================================

Case FD_CONNECT

    'Arrival of this message means that the connection initiated by the call
    'of the connect Winsock API function was successfully established.

    If ShowDebug Then Debug.Print "FD_CONNECT " & m_lngSocketHandle
    
    If m_enmState <> sckConnecting Then
        If ShowDebug Then Debug.Print "WARNING: Omitting FD_CONNECT"
        Exit Sub
    End If
    
    'Get the connection local end-point parameters
    lngResult = api_getpeername(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
        
    If lngResult = 0 Then
        m_lngRemotePort = modSocketMaster.IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port))
        m_strRemoteHostIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr))
    End If
    
    m_enmState = sckConnected: If ShowDebug Then Debug.Print "STATE: sckConnected"
    RaiseEvent Connect

'======================================================================

Case FD_WRITE

    'This message means that the socket in a write-able
    'state, that is, buffer for outgoing data of the transport
    'service is empty and ready to receive data to send through
    'the network.
    
    If ShowDebug Then Debug.Print "FD_WRITE " & m_lngSocketHandle
    
    If m_enmState <> sckConnected Then
        If ShowDebug Then Debug.Print "WARNING: Omitting FD_WRITE"
        Exit Sub
    End If
    
    If Len(m_strSendBuffer) > 0 Then
        SendBufferedData
    End If
    
'======================================================================

Case FD_READ

    'Some data has arrived for this socket.

    If ShowDebug Then Debug.Print "FD_READ " & m_lngSocketHandle
    
    If m_enmProtocol = sckTCPProtocol Then
        
        If m_enmState <> sckConnected Then
            If ShowDebug Then Debug.Print "WARNING: Omitting FD_READ"
            Exit Sub
        End If
        
        'Call the RecvDataToBuffer function that move arrived data
        'from the Winsock buffer to the local one and returns number
        'of bytes received.
    
        lngBytesReceived = RecvDataToBuffer
    
        If lngBytesReceived > 0 Then
            RaiseEvent DataArrival(Len(m_strRecvBuffer))
        End If
    
    Else 'UDP protocol
        
        If m_enmState <> sckOpen Then
            If ShowDebug Then Debug.Print "WARNING: Omitting FD_READ"
            Exit Sub
        End If
        
        'If we use UDP we don't remove data from winsock buffer.
        'We just let the user know the amount received so
        'he/she can decide what to do.
        
        lngBytesReceived = GetBufferLenUDP
        
        If lngBytesReceived > 0 Then
            RaiseEvent DataArrival(lngBytesReceived)
        End If
        
        
        'Now the buffer is emptied no matter what the user
        'dicided to do with the received data
        EmptyBuffer
    End If
    
    
'======================================================================

Case FD_ACCEPT

    'When the socket is in a listening state, arrival of this message
    'means that a connection request was received. Call the accept
    'Winsock API function in oreder to create a new socket for the
    'requested connection.
  
    If ShowDebug Then Debug.Print "FD_ACCEPT " & m_lngSocketHandle
    If m_enmState <> sckListening Then
        If ShowDebug Then Debug.Print "WARNING: Omitting FD_ACCEPT"
        Exit Sub
    End If
    
    lngResult = api_accept(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
    
    If lngResult = INVALID_SOCKET Then
        lngErrorCode = Err.LastDllError
        Err.Raise lngErrorCode, "CSocketMaster.PostSocket", GetErrorDescription(lngErrorCode)
    Else
        'We assign a temporal instance of CSocketMaster to
        'handle this new socket until user accepts (or not)
        'the new connection
        modSocketMaster.RegisterAccept lngResult
        
        'We change remote info before firing ConnectionRequest
        'event so the user can see which host is trying to
        'connect.
        
        Dim lngTempRP As Long
        Dim strTempRHIP As String
        Dim strTempRH As String
        lngTempRP = m_lngRemotePort
        strTempRHIP = m_strRemoteHostIP
        strTempRH = m_strRemoteHost
        
        GetRemoteInfo lngResult, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost
        
        If ShowDebug Then Debug.Print "OK Accepted socket: " & lngResult
        RaiseEvent ConnectionRequest(lngResult)
        
        'we return original info
        If m_enmState = sckListening Then
             m_lngRemotePort = lngTempRP
             m_strRemoteHostIP = strTempRHIP
             m_strRemoteHost = strTempRH
        End If
        
        'This is very important. If the connection wasn't accepted
        'we must close the socket.
        If IsAcceptRegistered(lngResult) Then
            api_closesocket lngResult
            modSocketMaster.UnregisterSocket lngResult
            modSocketMaster.UnregisterAccept lngResult
            If ShowDebug Then Debug.Print "OK Closed accepted socket: " & lngResult
        End If
    End If
    
'======================================================================
    
Case FD_CLOSE
    
    'This message means that the remote host is closing the conection
    
    If ShowDebug Then Debug.Print "FD_CLOSE " & m_lngSocketHandle
    
    If m_enmState <> sckConnected Then
        If ShowDebug Then Debug.Print "WARNING: Omitting FD_CLOSE"
        Exit Sub
    End If
    
    m_enmState = sckClosing: If ShowDebug Then Debug.Print "STATE: sckClosing"
    RaiseEvent CloseSck
    
End Select
End Sub

'Connect to a given 32 bits long ip
Private Sub ConnectToIP(ByVal lngRemoteHostAddress As Long, ByVal lngErrorCode As Long)

Dim blnCancelDisplay As Boolean

'Check and handle errors
If lngErrorCode <> 0 Then
    m_enmState = sckError: If ShowDebug Then Debug.Print "STATE: sckError"
    blnCancelDisplay = True
    RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ConnectToIP", "", 0, blnCancelDisplay)
    If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.ConnectToIP"
    Exit Sub
End If

'Here we bind the socket
If Not BindInternal Then Exit Sub

If ShowDebug Then Debug.Print "OK Connecting to: " + m_strRemoteHost + " " + m_strRemoteHostIP
m_enmState = sckConnecting: If ShowDebug Then Debug.Print "STATE: sckConnecting"

Dim udtSockAddr As sockaddr_in
Dim lngResult As Long

'Build the sockaddr_in structure to pass it to the connect
'Winsock API function as an address of the remote host.
With udtSockAddr
    .sin_addr = lngRemoteHostAddress
    .sin_family = AF_INET
    .sin_port = api_htons(modSocketMaster.UnsignedToInteger(m_lngRemotePort))
End With

'Call the connect Winsock API function in order to establish connection.
lngResult = api_connect(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))

'Check and handle errors
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: If ShowDebug Then Debug.Print "STATE: sckError"
            blnCancelDisplay = True
            RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ConnectToIP", "", 0, blnCancelDisplay)
            If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.ConnectToIP"
        End If
    End If
End If

End Sub

Public Sub Bind(Optional LocalPort As Variant, Optional LocalIP As Variant)
If m_enmState <> sckClosed Then
    Err.Raise sckInvalidOp, "CSocketMaster.Bind", "Invalid operation at current state"
End If

If BindInternal(LocalPort, LocalIP) Then
    m_enmState = sckOpen: If ShowDebug Then Debug.Print "STATE: sckOpen"
End If
End Sub

'This function binds a socket to a local port and IP.
'Retunrs TRUE if it has success.
Private Function BindInternal(Optional ByVal varLocalPort As Variant, Optional ByVal varLocalIP As Variant) As Boolean
If m_enmState = sckOpen Then
    BindInternal = True
    Exit Function
End If

Dim lngLocalPortInternal As Long
Dim strLocalHostInternal As String
Dim strIP As String
Dim lngAddressInternal As Long
Dim lngResult As Long
Dim lngErrorCode As Long

BindInternal = False

'Check if varLocalPort is a number between 0 and 65535
If Not IsMissing(varLocalPort) Then
    
    If IsNumeric(varLocalPort) Then
        If varLocalPort < 0 Or varLocalPort > 65535 Then
            BindInternal = False
            Err.Raise sckInvalidArg, "CSocketMaster.BindInternal", "The argument passed to a function was not in the correct format or in the specified range."
        Else
            lngLocalPortInternal = CLng(varLocalPort)
        End If
    Else
        BindInternal = False
        Err.Raise sckUnsupported, "CSocketMaster.BindInternal", "Unsupported variant type."
    End If
    
Else
    
    lngLocalPortInternal = m_lngLocalPort
    
End If

If Not IsMissing(varLocalIP) Then
    If varLocalIP <> vbNullString Then
        strLocalHostInternal = CStr(varLocalIP)
    Else
        strLocalHostInternal = GetLocalIP
    End If
Else
    strLocalHostInternal = GetLocalIP
End If

'get a 32 bits long IP
lngAddressInternal = ResolveIfHostnameSync(strLocalHostInternal, strIP, lngResult)

If lngResult <> 0 Then
    Err.Raise sckInvalidArg, "CSocketMaster.BindInternal", "Invalid argument"
End If

'create a socket if there isn't one yet
If Not SocketExists Then Exit Function

Dim udtSockAddr As sockaddr_in

With udtSockAddr
    .sin_addr = lngAddressInternal
    .sin_family = AF_INET
    .sin_port = api_htons(modSocketMaster.UnsignedToInteger(lngLocalPortInternal))
End With

'bind the socket
lngResult = api_bind(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))

If lngResult = SOCKET_ERROR Then

    lngErrorCode = Err.LastDllError
    Err.Raise lngErrorCode, "CSocketMaster.BindInternal", GetErrorDescription(lngErrorCode)
    
Else

    m_strLocalIP = strIP
    
    If lngLocalPortInternal <> 0 Then
    
        If ShowDebug Then Debug.Print "OK Bind HOST: " & strLocalHostInternal & " PORT: " & lngLocalPortInternal
        m_lngLocalPort = lngLocalPortInternal
        
    Else
        lngResult = GetLocalPort(m_lngSocketHandle)
        
        If lngResult = SOCKET_ERROR Then
            lngErrorCode = Err.LastDllError
            Err.Raise lngErrorCode, "CSocketMaster.BindInternal", GetErrorDescription(lngErrorCode)
        Else
            If ShowDebug Then Debug.Print "OK Bind HOST: " & strLocalHostInternal & " PORT: " & lngResult
            m_lngLocalPortBind = lngResult
        End If
        
    End If
    
    BindInternal = True
End If
End Function

'Allocate some memory for HOSTEN structure and returns
'a pointer to this buffer if no error occurs.
'Returns 0 if it fails.
Private Function AllocateMemory() As Long
m_lngMemoryHandle = api_GlobalAlloc(GMEM_FIXED, MAXGETHOSTSTRUCT)

If m_lngMemoryHandle <> 0 Then
    m_lngMemoryPointer = api_GlobalLock(m_lngMemoryHandle)
    
    If m_lngMemoryPointer <> 0 Then
        api_GlobalUnlock (m_lngMemoryHandle)
        AllocateMemory = m_lngMemoryPointer
    Else
        api_GlobalFree (m_lngMemoryHandle)
        AllocateMemory = m_lngMemoryPointer '0
    End If

Else
    AllocateMemory = m_lngMemoryHandle '0
End If
End Function

'Free memory allocated by AllocateMemory
Private Sub FreeMemory()
If m_lngMemoryHandle <> 0 Then
    m_lngMemoryHandle = 0
    m_lngMemoryPointer = 0
    api_GlobalFree m_lngMemoryHandle
End If
End Sub