msocketsupport.bas

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

        '
        'Just to let the caller know that the function was executed successfully
        CreateWinsockMessageWindow = p_lngWindowHandle
        '
        'Debug.Print "The window is created: " & p_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 p_lngWindowHandle, GWL_WNDPROC, m_lngPreviousValue
    'Destroy the window
    DestroyWindow p_lngWindowHandle
    '
    'Debug.Print "The window " & p_lngWindowHandle & " is destroyed"
    '
    'Reset the window handle variable
    p_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

'*************************************************************************
'**函 数 名：GetErrorDescription
'**输   入：ByVal lngErrorCode(Long) -
'**输   出：(String) -
'**功能描述：
'**全局变量：
'**调用模块：
'**作   者：
'**日   期：2006-12-01 10:38:27
'**修 改 人：
'**日   期：
'**版   本：V0.2.2
'*************************************************************************
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
            p_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