csocketmaster.cls

一个使用GPRS连接的WAP服务程序

    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

Private Function GetLocalHostName() As String
Dim strHostNameBuf As String * LOCAL_HOST_BUFF
Dim lngResult As Long

lngResult = api_gethostname(strHostNameBuf, LOCAL_HOST_BUFF)

If lngResult = SOCKET_ERROR Then
    GetLocalHostName = vbNullString
    Dim lngErrorCode As Long
    lngErrorCode = Err.LastDllError
    Err.Raise lngErrorCode, "CSocketMaster.GetLocalHostName", GetErrorDescription(lngErrorCode)
Else
    GetLocalHostName = Left(strHostNameBuf, InStr(1, strHostNameBuf, Chr(0)) - 1)
End If
End Function

Private Function GetLocalIP() As String
Dim lngResult As Long
Dim lngPtrToIP As Long
Dim strLocalHost As String
Dim arrIpAddress(1 To 4) As Byte
Dim Count As Integer
Dim udtHostent As HOSTENT
Dim strIpAddress As String

strLocalHost = GetLocalHostName

lngResult = api_gethostbyname(strLocalHost)

If lngResult = 0 Then
    GetLocalIP = vbNullString
    Dim lngErrorCode As Long
    lngErrorCode = Err.LastDllError
    Err.Raise lngErrorCode, "CSocketMaster.GetLocalIP", GetErrorDescription(lngErrorCode)
Else
    api_CopyMemory udtHostent, ByVal lngResult, LenB(udtHostent)
    api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4
    api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4
   
    For Count = 1 To 4
        strIpAddress = strIpAddress & arrIpAddress(Count) & "."
    Next
   
    strIpAddress = Left$(strIpAddress, Len(strIpAddress) - 1)
    GetLocalIP = strIpAddress
End If
End Function

'If Host is an IP doesn't resolve anything and returns a
'a 32 bits long IP.
'If Host isn't an IP then returns vbNull, tries to resolve it
'in asynchronous way and acts according to enmDestination.
Private Function ResolveIfHostname(ByVal Host As String, ByVal enmDestination As DestResolucion) As Long
Dim lngAddress As Long
lngAddress = api_inet_addr(Host)

If lngAddress = INADDR_NONE Then 'if Host isn't an IP
    
    ResolveIfHostname = vbNull
    m_enmState = sckResolvingHost: If ShowDebug Then Debug.Print "STATE: sckResolvingHost"
    
    If AllocateMemory Then
        
        Dim lngAsynHandle As Long
        lngAsynHandle = modSocketMaster.ResolveHost(Host, m_lngMemoryPointer, ObjPtr(Me))
        
        If lngAsynHandle = 0 Then
            FreeMemory
            m_enmState = sckError: If ShowDebug Then Debug.Print "STATE: sckError"
            Dim lngErrorCode As Long
            lngErrorCode = Err.LastDllError
            Dim blnCancelDisplay As Boolean
            blnCancelDisplay = True
            RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ResolveIfHostname", "", 0, blnCancelDisplay)
            If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.ResolveIfHostname"
        Else
            m_colWaitingResolutions.Add enmDestination, "R" & lngAsynHandle
            If ShowDebug Then Debug.Print "Resolving host " & Host; " with handle " & lngAsynHandle
        End If
        
    Else
        
        m_enmState = sckError: If ShowDebug Then Debug.Print "STATE: sckError"
        If ShowDebug Then Debug.Print "Error trying to allocate memory"
        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

'Resolves a hots (if necessary) in synchronous way
'If succeeds returns a 32 bits long IP,
'strHostIP = readable IP string and lngErrorCode = 0
'If fails returns vbNull,
'strHostIP = vbNullString and lngErrorCode <> 0
Private Function ResolveIfHostnameSync(ByVal Host 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 Integer

If Host = vbNullString Then
    strHostIP = vbNullString
    lngErrorCode = WSAEAFNOSUPPORT
    ResolveIfHostnameSync = vbNull
    Exit Function
End If

lngAddress = api_inet_addr(Host)

If lngAddress = INADDR_NONE Then 'if Host isn't an IP
    
    lngPtrToHOSTENT = api_gethostbyname(Host)
    
    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
        
        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 = Host
    ResolveIfHostnameSync = lngAddress
    
End If
End Function

'Returns local port from a connected or bound socket.
'Returns SOCKET_ERROR if fails.
Private Function GetLocalPort(ByVal lngSocket As Long) As Long
Dim udtSockAddr As sockaddr_in
Dim lngResult As Long

lngResult = api_getsockname(lngSocket, udtSockAddr, LenB(udtSockAddr))

If lngResult = SOCKET_ERROR Then
    GetLocalPort = SOCKET_ERROR
Else
    GetLocalPort = modSocketMaster.IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port))
End If
End Function

Public Sub SendData(data As Variant)

Dim arrData() As Byte 'We store the data here before send it

If m_enmProtocol = sckTCPProtocol Then
    If m_enmState <> sckConnected Then
        Err.Raise sckBadState, "CSocketMaster.SendData", "Wrong protocol or connection state for the requested transaction or request"