msocketsupport.bas

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

Public Declare Function api_closesocket Lib "ws2_32.dll" Alias "closesocket" (ByVal s As Long) As Long
Public Declare Function api_connect Lib "ws2_32.dll" Alias "connect" (ByVal s As Long, ByRef name As sockaddr_in, ByVal namelen As Long) As Long
Public Declare Function getsockname Lib "ws2_32.dll" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
Public Declare Function getpeername Lib "ws2_32.dll" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
Public Declare Function api_bind Lib "ws2_32.dll" Alias "bind" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
Public Declare Function api_select Lib "ws2_32.dll" Alias "select" (ByVal nfds As Long, ByRef readfds As Any, ByRef writefds As Any, ByRef exceptfds As Any, ByRef TimeOut As Long) As Long
Public Declare Function recv Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare Function send Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare Function shutdown Lib "ws2_32.dll" (ByVal s As Long, ByVal how As Long) As Long
Public Declare Function api_listen Lib "ws2_32.dll" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As Long
Public Declare Function api_accept Lib "ws2_32.dll" Alias "accept" (ByVal s As Long, ByRef addr As sockaddr_in, ByRef addrlen As Long) As Long
Public Declare Function setsockopt Lib "ws2_32.dll" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
Public Declare Function getsockopt Lib "ws2_32.dll" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, optlen As Long) As Long
Public Declare Function sendto Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long, ByRef toaddr As sockaddr_in, ByVal tolen As Long) As Long
Public Declare Function recvfrom Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long, ByRef from As sockaddr_in, ByRef fromlen As Long) As Long

Public Declare Function WSAAsyncSelect Lib "ws2_32.dll" (ByVal s As Long, ByVal hwnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long
Public Declare Function WSAAsyncGetHostByAddr Lib "ws2_32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByRef lngAddr As Long, ByVal lngLenght As Long, ByVal lngType As Long, buf As Any, ByVal lngBufLen As Long) As Long
Public Declare Function WSAAsyncGetHostByName Lib "ws2_32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal strHostName As String, buf As Any, ByVal buflen As Long) As Long
Public Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVR As Long, lpWSAD As WSAData) As Long
Public Declare Function WSACleanup Lib "ws2_32.dll" () As Long
'
Private Const GWL_WNDPROC = -4
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
'Added: 04-MAR-2002
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
'Added: 17-OCT-2002
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc&, ByVal hwnd&, ByVal Msg&, ByVal wParam&, ByVal lParam&) As Long

Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
'
Public Const GMEM_FIXED = &H0
Public Const GMEM_MOVEABLE = &H2
'
Public Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Public Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
'---------------------------------------------
'Modified: 23-AUG-2002
'---------------------------------------------
'The variable scope has been changed to Public to be
'visible from the CSocket class module
'Private m_lngWindowHandle   As Long
Public p_lngWindowHandle   As Long
'---------------------------------------------
Private m_colSockets        As Collection
Private m_colResolvers      As Collection
Private m_colMemoryBlocks   As Collection
Private m_lngPreviousValue  As Long

Private m_blnGetHostRecv    As Boolean
Private m_blnWinsockInit    As Boolean
Private m_lngMaxMsgSize     As Long

Private Const WM_USER = &H400
'
'Private Const RESOLVE_MESSAGE = WM_USER + 1
'Private Const SOCKET_MESSAGE = WM_USER + 2
'
Private m_lngResolveMessage As Long 'Added: 04-MAR-2002
'---------------------------------------------
'Modified: 23-AUG-2002
'---------------------------------------------
'The variable scope has been changed to Public to be
'visible from the CSocket class module
'Private m_lngWinsockMessage As Long 'Added: 04-MAR-2002
Public p_lngWinsockMessage As Long
'---------------------------------------------
'
Private Const OFFSET_4 = 4294967296#
Private Const MAXINT_4 = 2147483647
Private Const OFFSET_2 = 65536
Private Const MAXINT_2 = 32767



Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    '
    'This the callback function of the window created to hook
    'messages sent by the Winsock service. It handles only two
    'types of messages - network events for the sockets the
    'WSAAsyncSelect fucntion was called for, and the messages
    'sent in response to the WSAAsyncGetHostByName and
    'WSAAsyncGetHostByAddress Winsock API functions.
    '
    'Then the message is received, this function creates illegal
    'reference to the instance of the CSocket class and calls
    '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 = p_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
        '
    '---------------------------------------------------------------------
    'Added: 17-OCT-2002
    Else
        'Pass other messages to the original window procedure
        WindowProc = CallWindowProc(m_lngPreviousValue, hwnd, uMsg, wParam, lParam)
    '---------------------------------------------------------------------
    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.
'********************************************************************************
    '
    On Error GoTo ERROR_HANDLER     'Added: 04-JUNE-2002
    '
    Dim lngEvents   As Long
    Dim lngRetValue As Long
    '
    If p_lngWindowHandle = 0 Then
        '
        'We have no window to catch the network events.
        'Create a new one.
        p_lngWindowHandle = CreateWinsockMessageWindow
        '
        If p_lngWindowHandle = 0 Then
            '
            'Cannot create a new window.
            '---------------------------------------------------
            'Added: 04-JUNE-2002
            '---------------------------------------------------
            'Set the error info to pass to the caller subroutine
            Err.Number = sckOpCanceled
            Err.Description = "The operation was canceled."
            Err.Source = "MSocketSupport.RegisterSocket"
            '---------------------------------------------------
            'Just exit to return False
            Exit Function
            '
        End If
        '
    End If
    '