msocketsupport.bas

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

    'either the PostSocketEvent or PostGetHostEvent method of the
    'class to pass that message to the class.
    '
    Dim objSocket           As CSocket  'the illegal reference to an
                                        'instance of the CSocket class
    Dim lngObjPointer       As Long     'pointer to the existing instance
                                        'of the CSocket class
    Dim lngEventID          As Long     'network event
    Dim lngErrorCode        As Long     'code of the error message
    Dim lngMemoryHandle     As Long     'descriptor of the allocated
                                        'memory object
    Dim lngMemoryPointer    As Long     'pointer to the allocated memory
    Dim lngHostAddress      As Long     '32-bit host address
    Dim strHostName         As String   'a host hame
    Dim udtHost             As HostEnt  'structure of the data in the
                                        'allocated memory block
    Dim lngIpAddrPtr        As Long     'pointer to the IP address string
    '
    On Error GoTo ERORR_HANDLER
    '
    If uMsg = m_lngWinsockMessage Then  'Modified: 04-MAR-2002
    
        '
        'All the pointers to the existing instances of the CSocket class
        'are stored in the m_colSockets collection. Key of the collection's
        'item contains a value of the socket handle, and a value of the
        'collection item is the Long value that is a pointer the object,
        'instance of the CSocket class. Since the wParam argument of the
        'callback function contains a value of the socket handle the
        'function has received the network event message for, we can use
        'that value to get the object's pointer. With the pointer value
        'we can create the illegal reference to the object to be able to
        'call any Public or Friend subroutine of that object.
        '
        Set objSocket = SocketObjectFromPointer(CLng(m_colSockets("S" & wParam)))
        '
        'Retrieve the network event ID
        lngEventID = LoWord(lParam)
        'Retrieve the error code
        lngErrorCode = HiWord(lParam)
        '
        'Forward the message to the instance of the CSocket class
        objSocket.PostSocketEvent lngEventID, lngErrorCode
        '
    ElseIf uMsg = m_lngResolveMessage Then  'Modified: 04-MAR-2002
        '
        'A message has been received in response to the call of
        'the WSAAsyncGetHostByName or WSAAsyncGetHostByAddress.
        '
        'Retrieve the error code
        lngErrorCode = HiWord(lParam)
        '
        'The wParam parameter of the callback function contains
        'the task handle returned by the original function call
        '(see the ResolveHost function for more info). This value
        'is used as a key of the m_colResolvers collection item.
        'The item of that collection contains a pointer to the
        'instance of the CSocket class. So, if we know a value
        'of the task handle, we can find out the pointer to the
        'object which called the ResolveHost function in this module.
        '
        'Get the object pointer by the task handle value
        lngObjPointer = CLng(m_colResolvers("R" & wParam))
        '
        'A value of the pointer to the instance of the CSocket class
        'is used also as a key for the m_colMemoryBlocks collection
        'item that contains a handle of the allocated memory block
        'object. That memory block is the buffer where the
        'WSAAsyncGetHostByName and WSAAsyncGetHostByAddress functions
        'store the result HOSTENT structure.
        '
        'Get the handle of the allocated memory block object by the
        'pointer to the instance of the CSocket class.
        lngMemoryHandle = CLng(m_colMemoryBlocks("S" & lngObjPointer))
        '
        'Lock the memory block and get address of the buffer where
        'the HOSTENT structure data is stored.
        lngMemoryPointer = GlobalLock(lngMemoryHandle)
        '
        'Create an illegal reference to the instance of the
        'CSocket class
        Set objSocket = SocketObjectFromPointer(lngObjPointer)
        '
        'Now we can forward the message to that instance.
        '
        If lngErrorCode <> 0 Then
            '
            'If the host was not resolved, pass the error code value
            objSocket.PostGetHostEvent 0, 0, "", lngErrorCode
            '
        Else
            '
            'Move data from the allocated memory block to the
            'HOSTENT structure - udtHost
            CopyMemory udtHost, ByVal lngMemoryPointer, Len(udtHost)
            '
            'Get a 32-bit host address
            CopyMemory lngIpAddrPtr, ByVal udtHost.hAddrList, 4
            CopyMemory lngHostAddress, ByVal lngIpAddrPtr, 4
            '
            'Get a host name
            strHostName = StringFromPointer(udtHost.hName)
            '
            'Call the PostGetHostEvent friend method of the objSocket
            'to forward the retrieved information.
            objSocket.PostGetHostEvent wParam, lngHostAddress, strHostName
            '
        End If
        '
        'The task to resolve the host name is completed, thus we don't
        'need the allocated memory block anymore and corresponding items
        'in the m_colMemoryBlocks and m_colResolvers collections as well.
        '
        'Unlock the memory block
        Call GlobalUnlock(lngMemoryHandle)
        'Free that memory
        Call GlobalFree(lngMemoryHandle)
        '
        'Rremove the items from the collections
        m_colMemoryBlocks.Remove "S" & lngObjPointer
        m_colResolvers.Remove "R" & wParam
        '
        'If there are no more resolving tasks in progress,
        'destroy the collection objects to free resources.
        If m_colResolvers.Count = 0 Then
            Set m_colMemoryBlocks = Nothing
            Set m_colResolvers = Nothing
        End If
        '
    End If
    '
EXIT_LABEL:
    '
    Exit Function
    '
ERORR_HANDLER:
    '
    'Err.Raise Err.Number, "CSocket.WindowProc", Err.Description
    '
    'GoTo EXIT_LABEL
    '
End Function

Public Function RegisterSocket(ByVal lngSocketHandle As Long, ByVal lngObjectPointer As Long) As Boolean
'********************************************************************************
'Author    :Oleg Gdalevich
'Date/Time :17-12-2001
'Purpose   :Adds the socket to the m_colSockets collection, and
'           registers that socket with WSAAsyncSelect Winsock API
'           function to receive network events for the socket.
'           If this socket is the first one to be registered, the
'           window and collection will be created in this function as well.
'Arguments :lngSocketHandle  - the socket handle
'           lngObjectPointer - pointer to an object, instance of the CSocket class
'Returns   :If the argument is valid and no error occurred - True.
'********************************************************************************
    '
    Dim lngEvents   As Long
    Dim lngRetValue As Long
    '
    If m_lngWindowHandle = 0 Then
        '
        'We have no window to catch the network events.
        'Create a new one.
        m_lngWindowHandle = CreateWinsockMessageWindow
        '
        If m_lngWindowHandle = 0 Then
            '
            'Can't create a new window. Just exit to return False
            Exit Function
            '
        End If
        '
    End If
    '
    'The m_colSockets collection holds information
    'about all the sockets. If the current socket is
    'the first one, create the collection object.
    If m_colSockets Is Nothing Then
        Set m_colSockets = New Collection
    End If
    '
    'Add a new item to the m_colSockets collection.
    'The item key contains the socket handle, and the item's data
    'is the pointer to the instance of the CSocket class.
    m_colSockets.Add lngObjectPointer, "S" & lngSocketHandle
    '
    'The lngEvents variable contains a bitmask of events we are
    'going to catch with the window callback function.
    lngEvents = FD_CONNECT Or FD_READ Or FD_WRITE Or FD_CLOSE Or FD_ACCEPT
    '
    'Force the Winsock service to send the network event notifications
    'to the window which handle is m_lngWindowHandle.
    lngRetValue = WSAAsyncSelect(lngSocketHandle, m_lngWindowHandle, m_lngWinsockMessage, lngEvents)    'Modified:04-MAR-2002
    '
    'Return value of this function
    RegisterSocket = Not CBool(lngRetValue)
    '
    '
End Function

Public Function UnregisterSocket(ByVal lngSocketHandle As Long) As Boolean
'********************************************************************************
'Author    :Oleg Gdalevich
'Date/Time :17-12-2001
'Purpose   :Removes the socket from the m_colSockets collection
'           If it is the last socket in that collection, the window
'           and colection will be destroyed as well.
'Returns   :If the argument is valid and no error occurred - True.
'********************************************************************************
    '
    If (lngSocketHandle = INVALID_SOCKET) Or (m_colSockets Is Nothing) Then
        '
        'Something wrong with the caller of this function :)
        'Return False
        Exit Function
        '
    End If
    '
    Call WSAAsyncSelect(lngSocketHandle, m_lngWindowHandle, 0&, 0&)
    '
    'Remove the socket from the collection
    m_colSockets.Remove "S" & lngSocketHandle
    '
    UnregisterSocket = True
    '
    '
    If m_colSockets.Count = 0 Then
        '
        'If there are no more sockets in the collection
        'destroy the collection object and the window
        '
        Set m_colSockets = Nothing
        '
        '
        UnregisterSocket = DestroyWinsockMessageWindow
        '
    End If
    '
End Function

Public Function ResolveHost(strHostAddress As String, ByVal lngObjectPointer As Long) As Long
'********************************************************************************
'Author    :Oleg Gdalevich
'Date/Time :17-12-2001
'Purpose   :Receives requests to resolve a host address from the CSocket class.
'Returns   :If no errors occurred - ID of the request. Otherwise - 0.
'********************************************************************************
    '
    'Since this module is supposed to serve several instances of the
    'CSocket class, this function can be called to start several
    'resolving tasks that could be executed simultaneously. To
    'distinguish the resolving tasks the m_colResolvers collection
    'is used. The key of the collection's item contains a pointer to
    'the instance of the CSocket class and the item's data is the
    'Request ID, the value returned by the WSAAsyncGetHostByXXXX
    'Winsock API function. So in order to get the pointer to the
    'instance of the CSocket class by the task ID value the following
    'line of code can be used:
    '
    'lngObjPointer = CLng(m_colResolvers("R" & lngTaskID))
    '
    'The WSAAsyncGetHostByXXXX function needs the buffer (the buf argument)
    'where the data received from DNS server will be stored. We cannot use
    'a local byte array for this purpose as this buffer must be available
    'from another subroutine in this module - WindowProc, also we cannot
    'use a module level array as several tasks can be executed simultaneously
    'At least, we need a dynamic module level array of arrays - too complicated.
    'I decided to use Windows API functions for allocation some memory for
    'each resolving task: GlobalAlloc, GlobalLock, GlobalUnlock, and GlobalFree.
    '
    'To distinguish those memory blocks, the m_colMemoryBlocks collection is
    'used. The key of the collection's item contains value of the object
    'pointer, and the item's value is a handle of the allocated memory
    'block object, value returned by the GlobalAlloc function. So in order to
    'get value of the handle of the allocated memory block object by the
    'pointer to the instance of CSocket class we can use the following code:
    '
    'lngMemoryHandle = CLng(m_colMemoryBlocks("S" & lngObjPointer))
    '
    'Why do we need all this stuff?
    '
    'The problem is that the callback function give us only the resolving task
    'ID value, but we need information about:
    '   - where the data returned from the DNS server is stored
    '   - which instance of the CSocket class we need to post the info to
    '
    'So, if we know the task ID value, we can find out the object pointer:
    '   lngObjPointer = CLng(m_colResolvers("R" & lngTaskID))
    '
    'If we know the object pointer value we can find out where the data is strored:
    '   lngMemoryHandle = CLng(m_colMemoryBlocks("S" & lngObjPointer))
    '
    'That's it. :))
    '
    Dim lngAddress          As Long '32-bit host address
    Dim lngRequestID        As Long 'value returned by WSAAsyncGetHostByXXX
    Dim lngMemoryHandle     As Long 'handle of the allocated memory block object
    Dim lngMemoryPointer    As Long 'address of the memory block
    '
    'Allocate some memory
    lngMemoryHandle = GlobalAlloc(GMEM_FIXED, MAXGETHOSTSTRUCT)
    '
    If lngMemoryHandle > 0 Then
        '
        'Lock the memory block just to get the address
        'of that memory into the lngMemoryPointer variable
        lngMemoryPointer = GlobalLock(lngMemoryHandle)
        '
        If lngMemoryPointer = 0 Then
            '
            'Memory allocation error
            Call GlobalFree(lngMemoryHandle)
            Exit Function
            '
        Else
            'Unlock the memory block
            GlobalUnlock (lngMemoryHandle)
            '
        End If
        '
    Else
        '
        'Memory allocation error
        Exit Function
        '
    End If
    '
    'If this request is the first one, create the collections
    If m_colResolvers Is Nothing Then
        Set m_colMemoryBlocks = New Collection
        Set m_colResolvers = New Collection
    End If
    '
    'Remember the memory block location
    m_colMemoryBlocks.Add lngMemoryHandle, "S" & CStr(lngObjectPointer)
    '
    'Try to get 32-bit address
    lngAddress = inet_addr(strHostAddress)