modsocketmaster.bas

用VB编写的一个小程序

        Debug.Print "OK Winsock service initiated"
    Else
        Debug.Print "ERROR trying to initiate winsock service"
        Err.Raise lngResult, "modSocketMaster.InitiateProcesses", GetErrorDescription(lngResult)
        InitiateProcesses = lngResult
    End If
    
End If
End Function

'This function initiate the winsock service calling
'the api_WSAStartup funtion and returns resulting value.
Private Function InitiateService() As Long
Dim udtWSAData As WSAData
Dim lngResult As Long

lngResult = api_WSAStartup(SOCKET_VERSION_11, udtWSAData)
InitiateService = lngResult
End Function

'Once we are done with the class instance we call this
'function to discount it and finish winsock service if
'it was the last one.
'Returns 0 if it has success.
Public Function FinalizeProcesses() As Long
FinalizeProcesses = 0
m_lngSocksQuantity = m_lngSocksQuantity - 1

'if the service was initiated and there's no more instances
'of the class then we finish the service
If m_blnInitiated And m_lngSocksQuantity = 0 Then
    If FinalizeService = SOCKET_ERROR Then
        Dim lngErrorCode As Long
        lngErrorCode = Err.LastDllError
        FinalizeProcesses = lngErrorCode
        Err.Raise lngErrorCode, "modSocketMaster.FinalizeProcesses", GetErrorDescription(lngErrorCode)
    Else
        Debug.Print "OK Winsock service finalized"
    End If
    
    Subclass_Terminate
    m_blnInitiated = False
End If

End Function

'Finish winsock service calling the function
'api_WSACleanup and returns the result.
Private Function FinalizeService() As Long
Dim lngResultado As Long
lngResultado = api_WSACleanup
FinalizeService = lngResultado
End Function

'This function receives a number that represents an error
'and returns the corresponding description string.
Public Function GetErrorDescription(ByVal lngErrorCode As Long) As String
Select Case lngErrorCode
    Case WSAEACCES
        GetErrorDescription = "Permission denied."
    Case WSAEADDRINUSE
        GetErrorDescription = "Address already in use."
    Case WSAEADDRNOTAVAIL
        GetErrorDescription = "Cannot assign requested address."
    Case WSAEAFNOSUPPORT
        GetErrorDescription = "Address family not supported by protocol family."
    Case WSAEALREADY
        GetErrorDescription = "Operation already in progress."
    Case WSAECONNABORTED
        GetErrorDescription = "Software caused connection abort."
    Case WSAECONNREFUSED
        GetErrorDescription = "Connection refused."
    Case WSAECONNRESET
        GetErrorDescription = "Connection reset by peer."
    Case WSAEDESTADDRREQ
        GetErrorDescription = "Destination address required."
    Case WSAEFAULT
        GetErrorDescription = "Bad address."
    Case WSAEHOSTUNREACH
        GetErrorDescription = "No route to host."
    Case WSAEINPROGRESS
        GetErrorDescription = "Operation now in progress."
    Case WSAEINTR
        GetErrorDescription = "Interrupted function call."
    Case WSAEINVAL
        GetErrorDescription = "Invalid argument."
    Case WSAEISCONN
        GetErrorDescription = "Socket is already connected."
    Case WSAEMFILE
        GetErrorDescription = "Too many open files."
    Case WSAEMSGSIZE
        GetErrorDescription = "Message too long."
    Case WSAENETDOWN
        GetErrorDescription = "Network is down."
    Case WSAENETRESET
        GetErrorDescription = "Network dropped connection on reset."
    Case WSAENETUNREACH
        GetErrorDescription = "Network is unreachable."
    Case WSAENOBUFS
        GetErrorDescription = "No buffer space available."
    Case WSAENOPROTOOPT
        GetErrorDescription = "Bad protocol option."
    Case WSAENOTCONN
        GetErrorDescription = "Socket is not connected."
    Case WSAENOTSOCK
        GetErrorDescription = "Socket operation on nonsocket."
    Case WSAEOPNOTSUPP
        GetErrorDescription = "Operation not supported."
    Case WSAEPFNOSUPPORT
        GetErrorDescription = "Protocol family not supported."
    Case WSAEPROCLIM
        GetErrorDescription = "Too many processes."
    Case WSAEPROTONOSUPPORT
        GetErrorDescription = "Protocol not supported."
    Case WSAEPROTOTYPE
        GetErrorDescription = "Protocol wrong type for socket."
    Case WSAESHUTDOWN
        GetErrorDescription = "Cannot send after socket shutdown."
    Case WSAESOCKTNOSUPPORT
        GetErrorDescription = "Socket type not supported."
    Case WSAETIMEDOUT
        GetErrorDescription = "Connection timed out."
    Case WSAEWOULDBLOCK
        GetErrorDescription = "Resource temporarily unavailable."
    Case WSAHOST_NOT_FOUND
        GetErrorDescription = "Host not found."
    Case WSANOTINITIALISED
        GetErrorDescription = "Successful WSAStartup not yet performed."
    Case WSANO_DATA
        GetErrorDescription = "Valid name, no data record of requested type."
    Case WSANO_RECOVERY
        GetErrorDescription = "This is a nonrecoverable error."
    Case WSASYSNOTREADY
        GetErrorDescription = "Network subsystem is unavailable."
    Case WSATRY_AGAIN
        GetErrorDescription = "Nonauthoritative host not found."
    Case WSAVERNOTSUPPORTED
        GetErrorDescription = "Winsock.dll version out of range."
    Case Else
        GetErrorDescription = "Unknown error."
End Select

End Function

'Create a window that is used to capture sockets messages.
'Returns 0 if it has success.
Private Function CreateWinsockMessageWindow() As Long
m_lngWindowHandle = api_CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)

If m_lngWindowHandle = 0 Then
    CreateWinsockMessageWindow = sckOutOfMemory
    Exit Function
Else
    CreateWinsockMessageWindow = 0
    Debug.Print "OK Created winsock message window " & m_lngWindowHandle
End If
End Function

'Destroy the window that is used to capture sockets messages.
'Returns 0 if it has success.
Private Function DestroyWinsockMessageWindow() As Long
DestroyWinsockMessageWindow = 0

If m_lngWindowHandle = 0 Then
    Debug.Print "WARNING lngWindowHandle is ZERO"
    Exit Function
End If
    
Dim lngResult As Long

lngResult = api_DestroyWindow(m_lngWindowHandle)
    
If lngResult = 0 Then
    DestroyWinsockMessageWindow = sckOutOfMemory
    Err.Raise sckOutOfMemory, "modSocketMaster.DestroyWinsockMessageWindow", "Out of memory"
Else
    Debug.Print "OK Destroyed winsock message window " & m_lngWindowHandle
    m_lngWindowHandle = 0
End If
    
End Function

'When a socket needs to resolve a hostname in asynchronous way
'it calls this function. If it has success it returns a nonzero
'number that represents the async task handle and register this
'number in the TableA list.
'Returns 0 if it fails.
Public Function ResolveHost(ByVal strHost As String, ByVal lngHOSTENBuf As Long, ByVal lngObjectPointer As Long) As Long
Dim lngAsynHandle As Long
lngAsynHandle = api_WSAAsyncGetHostByName(m_lngWindowHandle, RESOLVE_MESSAGE, strHost, ByVal lngHOSTENBuf, MAXGETHOSTSTRUCT)
If lngAsynHandle <> 0 Then Subclass_AddResolveMessage lngAsynHandle, lngObjectPointer
ResolveHost = lngAsynHandle
End Function

'Returns the hi word from a double word.
Public Function HiWord(lngValue As Long) As Long
If (lngValue And &H80000000) = &H80000000 Then
    HiWord = ((lngValue And &H7FFF0000) \ &H10000) Or &H8000&
Else
    HiWord = (lngValue And &HFFFF0000) \ &H10000
End If
End Function

'Returns the low word from a double word.
Public Function LoWord(lngValue As Long) As Long
LoWord = (lngValue And &HFFFF&)
End Function

'Receives a string pointer and it turns it into a regular string.
Public Function StringFromPointer(ByVal lPointer As Long) As String
Dim strTemp As String
Dim lRetVal As Long

strTemp = String$(api_lstrlen(ByVal lPointer), 0)
lRetVal = api_lstrcpy(ByVal strTemp, ByVal lPointer)
If lRetVal Then StringFromPointer = strTemp
End Function

'The function takes an unsigned Integer from and API and