msocketsupport.bas

简单、实用、特别。 有很多不足之处

    '
    If lngAddress = INADDR_NONE Then
        '
        'If strHostAddress is not an IP address, try to resolve by name
        lngRequestID = WSAAsyncGetHostByName(m_lngWindowHandle, m_lngResolveMessage, strHostAddress, ByVal lngMemoryPointer, MAXGETHOSTSTRUCT)  'Modified: 04-MAR-2002
        '
    Else
        '
        'strHostAddress contains an IP address, resolve by address to get a host name
        lngRequestID = WSAAsyncGetHostByAddr(m_lngWindowHandle, m_lngResolveMessage, lngAddress, 4&, AF_INET, ByVal lngMemoryPointer, MAXGETHOSTSTRUCT) 'Modified: 04-MAR-2002
        '
    End If
    '
    If lngRequestID <> 0 Then
        '
        'If the call of the WSAAsyncGetHostByXXXX is successful, the
        'lngRequestID variable contains the task ID value.
        'Remember it.
        m_colResolvers.Add lngObjectPointer, "R" & CStr(lngRequestID)
        '
        'Return value
        ResolveHost = lngRequestID
        '
    Else
        '
        'If the call of the WSAAsyncGetHostByXXXX is not successful,
        'remove the item from the m_colMemoryBlocks collection.
        m_colMemoryBlocks.Remove ("S" & CStr(lngObjectPointer))
        '
        'Free allocated memory block
        Call GlobalFree(lngMemoryHandle)
        '
        'If there are no more resolving tasks in progress,
        'destroy the collection objects.
        If m_colResolvers.Count = 0 Then
            Set m_colResolvers = Nothing
            Set m_colMemoryBlocks = Nothing
        End If
        '
    End If
    '
End Function

Private Function CreateWinsockMessageWindow() As Long
'********************************************************************************
'Author    :Oleg Gdalevich
'Date/Time :17-12-2001
'Purpose   :Creates a window to hook the winsock messages
'Returns   :The window handle
'********************************************************************************
    '
    'Create a window. It will be used for hooking messages for registered
    'sockets, and we'll not see this window as the ShowWindow is never called.
    m_lngWindowHandle = CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)
    '
    If m_lngWindowHandle = 0 Then
        '
        'I really don't know - is this possible? Probably - yes,
        'due the lack of the system resources, for example.
        '
        'In this case the function returns 0.
        '
    Else
        '
        'Register a callback function for the window created a moment ago in this function
        'm_lngPreviousValue - stores the returned value that is the pointer to the previous
        'callback window function. We'll need this value to destroy the window.
        m_lngPreviousValue = SetWindowLong(m_lngWindowHandle, GWL_WNDPROC, AddressOf WindowProc)
        '
        'Just to let the caller know that the function was executed successfully
        CreateWinsockMessageWindow = m_lngWindowHandle
        '
        '
    End If
    '
End Function


Private Function DestroyWinsockMessageWindow() As Boolean
'********************************************************************************
'Author    :Oleg Gdalevich
'Date/Time :17-12-2001
'Purpose   :Destroyes the window
'Returns   :If the window was destroyed successfully - True.
'********************************************************************************
    '
    On Error GoTo ERR_HANDLER
    '
    'Return the previous window procedure
    SetWindowLong m_lngWindowHandle, GWL_WNDPROC, m_lngPreviousValue
    'Destroy the window
    DestroyWindow m_lngWindowHandle
    '
    '
    'Reset the window handle variable
    m_lngWindowHandle = 0
    'If no errors occurred, the function returns True
    DestroyWinsockMessageWindow = True
    '
ERR_HANDLER:

End Function

Private Function SocketObjectFromPointer(ByVal lngPointer As Long) As CSocket
    '
    Dim objSocket As CSocket
    '
    CopyMemory objSocket, lngPointer, 4&
    Set SocketObjectFromPointer = objSocket
    CopyMemory objSocket, 0&, 4&
    '
End Function

Private Function LoWord(lngValue As Long) As Long
   LoWord = (lngValue And &HFFFF&)
End Function

Private 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

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

Public Function InitWinsockService() As Long
    '
    'This functon does two things; it initializes the Winsock
    'service and returns value of maximum size of the UDP
    'message. Since this module is supposed to serve multiple
    'instances of the CSocket class, this function can be
    'called several times. But we need to call the WSAStartup
    'Winsock API function only once when the first instance of
    'the CSocket class is created.
    '
    Dim lngRetVal       As Long     'value returned by WSAStartup
    Dim strErrorMsg     As String   'error description string
    Dim udtWinsockData  As WSADATA  'structure to pass to WSAStartup as an argument
    '
    If Not m_blnWinsockInit Then
        '
        'start up winsock service
        lngRetVal = WSAStartup(&H101, udtWinsockData)
        '
        If lngRetVal <> 0 Then
            '
            'The system cannot load the Winsock library.
            '
            Select Case lngRetVal
                Case WSASYSNOTREADY
                    strErrorMsg = "The underlying network subsystem is not " & _
                                  "ready for network communication."
                Case WSAVERNOTSUPPORTED
                    strErrorMsg = "The version of Windows Sockets API support " & _
                                  "requested is not provided by this particular " & _
                                  "Windows Sockets implementation."
                Case WSAEINVAL
                    strErrorMsg = "The Windows Sockets version specified by the " & _
                                  "application is not supported by this DLL."
            End Select
            '
            Err.Raise Err.LastDllError, "MSocketSupport.InitWinsockService", strErrorMsg
            '
        Else
            '
            'The Winsock library is loaded successfully.
            '
            m_blnWinsockInit = True
            '
            'This function returns returns value of
            'maximum size of the UDP message
            m_lngMaxMsgSize = IntegerToUnsigned(udtWinsockData.iMaxUdpDg)
            InitWinsockService = m_lngMaxMsgSize
            '
            m_lngResolveMessage = RegisterWindowMessage(App.EXEName & ".ResolveMessage")    'Added: 04-MAR-2002
            m_lngWinsockMessage = RegisterWindowMessage(App.EXEName & ".WinsockMessage")    'Added: 04-MAR-2002
            '
            '
        End If
        '
    Else
        '
        'If this function has been called before by another
        'instance of the CSocket class, the code to init the
        'Winsock service must not be executed, but the function
        'returns maximum size of the UDP message anyway.
        InitWinsockService = m_lngMaxMsgSize
        '
    End If
    '
End Function

Public Sub CleanupWinsock()
'********************************************************************************
'This subroutine is called from the Class_Terminate() event
'procedure of any instance of the CSocket class. But the WSACleanup
'Winsock API function is called only if the calling object is the
'last instance of the CSocket class within the current process.
'********************************************************************************
    '
    'If the Winsock library was loaded
    'before and there are no more sockets.
    If m_blnWinsockInit And m_colSockets Is Nothing Then
        '
        'Unload library and free the system resources
        Call WSACleanup
        '
        'Turn off the m_blnWinsockInit flag variable
        m_blnWinsockInit = False
        '
    End If
    '
End Sub

Public Function StringFromPointer(ByVal lPointer As Long) As String
    '
    Dim strTemp As String
    Dim lRetVal As Long
    '
    'prepare the strTemp buffer
    strTemp = String$(lstrlen(ByVal lPointer), 0)
    '
    'copy the string into the strTemp buffer
    lRetVal = lstrcpy(ByVal strTemp, ByVal lPointer)
    '
    'return a string
    If lRetVal Then StringFromPointer = strTemp
    '
End Function

Public Function UnsignedToLong(Value As Double) As Long
    '
    'The function takes a Double containing a value in the