msocketsupport.bas

局域网用户屏幕的控制和查看程序

    '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
        'Debug.Print "The m_colSockets is created"
    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 p_lngWindowHandle.
    lngRetValue = WSAAsyncSelect(lngSocketHandle, p_lngWindowHandle, p_lngWinsockMessage, lngEvents)    'Modified:04-MAR-2002
    '
    '------------------------------------------------------------------
    'Added: 04-JUNE-2002
    '------------------------------------------------------------------
    If lngRetValue = SOCKET_ERROR Then
        '
        'If the WSAAsyncSelect call failed this function must
        'return False. In this case, the caller subroutine will
        'raise an error. Let's pass the error info with the Err object.
        '
        RegisterSocket = False
        '
        Err.Number = Err.LastDllError
        Err.Description = GetErrorDescription(Err.LastDllError)
        Err.Source = "MSocketSupport.RegisterSocket"
        '
    Else
        '
        RegisterSocket = True
        '
    End If
    '-------------------------------------------------------------------
    'Debug.Print lngSocketHandle & ": registered"
    '
    Exit Function           'Added: 04-JUNE-2002
    '
ERROR_HANDLER:              'Added: 04-JUNE-2002
    '
    RegisterSocket = False  'Added: 04-JUNE-2002
    '
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, p_lngWindowHandle, 0&, 0&)
    '
    'Remove the socket from the collection
    m_colSockets.Remove "S" & lngSocketHandle
    '
    UnregisterSocket = True
    '
    'Debug.Print lngSocketHandle & ": unregistered"
    '
    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
        '
        'Debug.Print "m_colSockets destroyed"
        '
        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
    '
    '------------------------------------------------------------------
    'Added: 09-JULY-2002
    '------------------------------------------------------------------
    Dim strKey As String
    '
    strKey = "S" & CStr(lngObjectPointer)
    '
    Call RemoveIfExists(strKey)
    '------------------------------------------------------------------
    'Remember the memory block location
    m_colMemoryBlocks.Add lngMemoryHandle, strKey
    '
    '------------------------------------------------------------------
    'Modified: 08-JULY-2002
    '------------------------------------------------------------------
    'Here is a major change. Since version 1.0.6 (08-JULY-2002) the
    'SCocket class doesn't try to resolve the IP address into a
    'domain name while connecting.
    '------------------------------------------------------------------
    '
    'Try to get 32-bit address
    'lngAddress = inet_addr(strHostAddress)
    '
    'If lngAddress = INADDR_NONE Then
        '
        'If strHostAddress is not an IP address, try to resolve by name
        lngRequestID = WSAAsyncGetHostByName(p_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(p_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
        '
        'Set the error info.
        Err.Number = Err.LastDllError
        Err.Description = GetErrorDescription(Err.LastDllError)
        Err.Source = "MSocketSupport.ResolveHost"
        '
    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.
    p_lngWindowHandle = CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)
    '
    If p_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(p_lngWindowHandle, GWL_WNDPROC, AddressOf WindowProc)