csocketmaster.cls

来自「支持监控包括传输控制协议和 UDP 的所有的互联网传输协议。同时程序具有实时文件」· CLS 代码 · 共 1,026 行 · 第 1/3 页

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CSocketMaster"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：2007/09/20
'描    述：界面清爽VB版高级专业防火墙 Ver 2.0.3
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************

Option Explicit
Public Enum SockState
    sckClosed = 0
    sckOpen
    sckListening
    sckConnectionPending
    sckResolvingHost
    sckHostResolved
    sckConnecting
    sckConnected
    sckClosing
    sckError
End Enum
#If False Then 'Trick preserves Case of Enums when typing in IDE
Private sckClosed, sckOpen, sckListening, sckConnectionPending, sckResolvingHost, sckHostResolved, sckConnecting, sckConnected
Private sckClosing, sckError
#End If
Public Enum DestResolucion 'asynchronic host resolution destination
    destConnect = 0
End Enum
#If False Then 'Trick preserves Case of Enums when typing in IDE
Private destConnect
#End If
'Private Const SOMAXCONN                             As Long = 5
Public Enum ProtocolConstants
    sckTCPProtocol = 0
    sckUDPProtocol = 1
End Enum
#If False Then 'Trick preserves Case of Enums when typing in IDE
Private sckTCPProtocol, sckUDPProtocol
#End If
Private Const MSG_PEEK                              As Long = &H2
Public Event CloseSck()
Public Event Connect()
Public Event ConnectionRequest(ByVal requestID As Long)
Public Event DataArrival(ByVal bytesTotal As Long)
Public Event Error(ByVal Number As Integer, Description As String, ByVal sCode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Public Event SendComplete()
Public Event SendProgress(ByVal BytesSent As Long, ByVal bytesRemaining As Long)
Private m_lngSocketHandle                           As Long      'socket handle
Private m_enmState                                  As SockState 'socket state
Private m_strTag                                    As String    'tag
Private m_strRemoteHost                             As String    'remote host
Private m_lngRemotePort                             As Long      'remote port
Private m_strRemoteHostIP                           As String    'remote host ip
Private m_lngLocalPort                              As Long      'local port
Private m_lngLocalPortBind                          As Long      'temporary local port
Private m_strLocalIP                                As String    'local IP
Private m_enmProtocol                               As ProtocolConstants 'protocol used (TCP / UDP)
Private m_lngMemoryPointer                          As Long
'memory pointer used as buffer when resolving host
Private m_lngMemoryHandle                           As Long      'buffer memory handle
Private m_lngSendBufferLen                          As Long      'winsock buffer size for sends
Private m_lngRecvBufferLen                          As Long
'winsock buffer size for receives
Private m_strSendBuffer                             As String    'local incoming buffer
Private m_strRecvBuffer                             As String    'local outgoing buffer
Private m_blnAcceptClass                            As Boolean
'if True then this is a Accept socket class
Private m_colWaitingResolutions                     As Collection
'hosts waiting to be resolved by the system
Private Declare Function api_socket Lib "ws2_32.dll" Alias "socket" (ByVal af As Long, _
                                                                     ByVal s_type As Long, _
                                                                     ByVal Protocol As Long) As Long
Private Declare Function api_GlobalLock Lib "kernel32" Alias "GlobalLock" (ByVal hMem As Long) As Long
Private Declare Function api_GlobalUnlock Lib "kernel32" Alias "GlobalUnlock" (ByVal hMem As Long) As Long
Private Declare Function api_htons Lib "ws2_32.dll" Alias "htons" (ByVal hostshort As Integer) As Integer
Private Declare Function api_ntohs Lib "ws2_32.dll" Alias "ntohs" (ByVal netshort As Integer) As Integer
Private 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
Private Declare Function api_gethostname Lib "ws2_32.dll" Alias "gethostname" (ByVal host_name As String, _
                                                                               ByVal namelen As Long) As Long
Private Declare Function api_gethostbyname Lib "ws2_32.dll" Alias "gethostbyname" (ByVal host_name As String) As Long
Private 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
Private Declare Function api_getsockname Lib "ws2_32.dll" Alias "getsockname" (ByVal s As Long, _
                                                                               ByRef name As sockaddr_in, _
                                                                               ByRef namelen As Long) As Long
Private Declare Function api_getpeername Lib "ws2_32.dll" Alias "getpeername" (ByVal s As Long, _
                                                                               ByRef name As sockaddr_in, _
                                                                               ByRef namelen As Long) As Long
Private Declare Function api_inet_addr Lib "ws2_32.dll" Alias "inet_addr" (ByVal cp As String) As Long
Private Declare Function api_send Lib "ws2_32.dll" Alias "send" (ByVal s As Long, _
                                                                 ByRef buf As Any, _
                                                                 ByVal buflen As Long, _
                                                                 ByVal flags As Long) As Long
Private Declare Function api_sendto Lib "ws2_32.dll" Alias "sendto" (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
Private Declare Function api_getsockopt Lib "ws2_32.dll" Alias "getsockopt" (ByVal s As Long, _
                                                                             ByVal level As Long, _
                                                                             ByVal optname As Long, _
                                                                             optval As Any, _
                                                                             optlen As Long) As Long
Private Declare Function api_setsockopt Lib "ws2_32.dll" Alias "setsockopt" (ByVal s As Long, _
                                                                             ByVal level As Long, _
                                                                             ByVal optname As Long, _
                                                                             optval As Any, _
                                                                             ByVal optlen As Long) As Long
Private Declare Function api_recv Lib "ws2_32.dll" Alias "recv" (ByVal s As Long, _
                                                                 ByRef buf As Any, _
                                                                 ByVal buflen As Long, _
                                                                 ByVal flags As Long) As Long
Private Declare Function api_recvfrom Lib "ws2_32.dll" Alias "recvfrom" (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
Private Declare Function api_WSACancelAsyncRequest Lib "ws2_32.dll" Alias "WSACancelAsyncRequest" (ByVal hAsyncTaskHandle As Long) As Long
''Private Declare Function api_listen Lib "ws2_32.dll" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As Long
''Private 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
Private Declare Function api_inet_ntoa Lib "ws2_32.dll" Alias "inet_ntoa" (ByVal inn As Long) As Long
''Private Declare Function api_gethostbyaddr Lib "ws2_32.dll" Alias "gethostbyaddr" (addr As Long, ByVal addr_len As Long, ByVal addr_type As Long) As Long
Private Declare Function api_ioctlsocket Lib "ws2_32.dll" Alias "ioctlsocket" (ByVal s As Long, _
                                                                               ByVal cmd As Long, _
                                                                               ByRef argp As Long) As Long
Private Declare Function api_closesocket Lib "ws2_32.dll" Alias "closesocket" (ByVal s As Long) As Long
Public Sub Accept(requestID As Long)
Dim lngResult    As Long
Dim udtSockAddr  As sockaddr_in
Dim lngErrorCode As Long
Dim clsSocket    As CSocketMaster
    If m_enmState <> sckClosed Then
        Err.Raise sckInvalidOp, "CSocketMaster.Accept", "Invalid operation at current state"
    End If
    m_lngSocketHandle = requestID
    m_enmProtocol = sckTCPProtocol
    ProcessOptions
    If Not modSocketMaster.IsAcceptRegistered(requestID) Then
        If IsSocketRegistered(requestID) Then
            Err.Raise sckBadState, "CSocketMaster.Accept", "Wrong protocol or connection state for the requested transaction or request"
        Else
            m_blnAcceptClass = True
            m_enmState = sckConnected
            modSocketMaster.RegisterSocket m_lngSocketHandle, ObjPtr(Me), False
            Exit Sub
        End If
    End If
    Set clsSocket = GetAcceptClass(requestID)
    modSocketMaster.UnregisterAccept requestID
    lngResult = api_getsockname(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
    If lngResult = SOCKET_ERROR Then
        lngErrorCode = Err.LastDllError
        Err.Raise lngErrorCode, "CSocketMaster.Accept", GetErrorDescription(lngErrorCode)
    Else
        m_lngLocalPortBind = IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port))
        m_strLocalIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr))
    End If
    GetRemoteInfo m_lngSocketHandle, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost
    m_enmState = sckConnected
    If clsSocket.BytesReceived > 0 Then
        clsSocket.GetData m_strRecvBuffer
    End If
    modSocketMaster.Subclass_ChangeOwner requestID, ObjPtr(Me)
    If Len(m_strRecvBuffer) > 0 Then
        RaiseEvent DataArrival(Len(m_strRecvBuffer))
    End If
    If clsSocket.State = sckClosing Then
        m_enmState = sckClosing
        RaiseEvent CloseSck
    End If
    Set clsSocket = Nothing
End Sub
Private Function AllocateMemory() As Long
    m_lngMemoryHandle = api_GlobalAlloc(GMEM_FIXED, MAXGETHOSTSTRUCT)
    If m_lngMemoryHandle <> 0 Then
        m_lngMemoryPointer = api_GlobalLock(m_lngMemoryHandle)
        If m_lngMemoryPointer <> 0 Then
            api_GlobalUnlock (m_lngMemoryHandle)
            AllocateMemory = m_lngMemoryPointer
        Else
            api_GlobalFree (m_lngMemoryHandle)
            AllocateMemory = m_lngMemoryPointer '0
        End If
    Else
        AllocateMemory = m_lngMemoryHandle '0
    End If
End Function
Private Function BindInternal(Optional ByVal varLocalPort As Variant, _
                              Optional ByVal varLocalIP As Variant) As Boolean
Dim lngLocalPortInternal As Long
Dim strLocalHostInternal As String
Dim strIP                As String
Dim lngAddressInternal   As Long
Dim lngResult            As Long
Dim lngErrorCode         As Long
Dim udtSockAddr          As sockaddr_in
    On Error Resume Next
    If m_enmState = sckOpen Then
        BindInternal = True
    Else
        BindInternal = False
        If Not IsMissing(varLocalPort) Then
            If IsNumeric(varLocalPort) Then
                If varLocalPort < 0 Or varLocalPort > 65535 Then
                    BindInternal = False
                    Err.Raise sckInvalidArg, "CSocketMaster.BindInternal", "The argument passed to a function was not in the correct format or in the specified range."
                Else
                    lngLocalPortInternal = CLng(varLocalPort)
                End If
            Else
                BindInternal = False
                Err.Raise sckUnsupported, "CSocketMaster.BindInternal", "Unsupported variant type."
            End If
        Else
            lngLocalPortInternal = m_lngLocalPort
        End If
        If Not IsMissing(varLocalIP) Then
            If varLocalIP <> vbNullString Then
                strLocalHostInternal = CStr(varLocalIP)
            Else
                strLocalHostInternal = GetLocalIP
            End If
        Else
            strLocalHostInternal = GetLocalIP
        End If
        lngAddressInternal = ResolveIfHostnameSync(strLocalHostInternal, strIP, lngResult)
        If lngResult <> 0 Then
            Err.Raise sckInvalidArg, "CSocketMaster.BindInternal", "Invalid argument"
        End If
        If Not SocketExists Then
            Exit Function
        End If
        With udtSockAddr
            .sin_addr = lngAddressInternal
            .sin_family = AF_INET
            .sin_port = api_htons(modSocketMaster.UnsignedToInteger(lngLocalPortInternal))
        End With
        lngResult = api_bind(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
        If lngResult = SOCKET_ERROR Then
            lngErrorCode = Err.LastDllError
            Err.Raise lngErrorCode, "CSocketMaster.BindInternal", GetErrorDescription(lngErrorCode)
        Else
            m_strLocalIP = strIP
            If lngLocalPortInternal <> 0 Then
                m_lngLocalPort = lngLocalPortInternal
            Else
                lngResult = GetLocalPort(m_lngSocketHandle)
                If lngResult = SOCKET_ERROR Then
                    lngErrorCode = Err.LastDllError
                    Err.Raise lngErrorCode, "CSocketMaster.BindInternal", GetErrorDescription(lngErrorCode)
                Else
                    m_lngLocalPortBind = lngResult
                End If
            End If
            BindInternal = True
        End If
        On Error GoTo 0
    End If
End Function
Private Function BuildArray(ByVal Size As Long, _
                            ByVal blnPeek As Boolean, _
                            ByRef lngErrorCode As Long) As Byte()
Dim strdata     As String
Dim arrBuffer() As Byte
Dim lngResult   As Long
Dim udtSockAddr As sockaddr_in
Dim lngFlags    As Long
    If m_enmProtocol = sckTCPProtocol Then
        strdata = Left$(m_strRecvBuffer, CLng(Size))
        BuildArray = StrConv(strdata, vbFromUnicode)
        If Not blnPeek Then
            m_strRecvBuffer = Mid$(m_strRecvBuffer, Size + 1)
        End If
    Else 'UDP protocol
        If blnPeek Then
            lngFlags = MSG_PEEK
        End If
        ReDim arrBuffer(Size - 1) As Byte
        lngResult = api_recvfrom(m_lngSocketHandle, arrBuffer(0), Size, lngFlags, udtSockAddr, LenB(udtSockAddr))
        If lngResult = SOCKET_ERROR Then
            lngErrorCode = Err.LastDllError
        End If
        BuildArray = arrBuffer
        GetRemoteInfoFromSI udtSockAddr, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost
    End If
End Function
Public Property Get BytesReceived() As Long
    If m_enmProtocol = sckTCPProtocol Then
        BytesReceived = Len(m_strRecvBuffer)
    Else
        BytesReceived = GetBufferLenUDP
    End If
End Property
Private Sub Class_Initialize()
    m_lngSocketHandle = INVALID_SOCKET
    Set m_colWaitingResolutions = New Collection
    modSocketMaster.InitiateProcesses
End Sub
Private Sub Class_Terminate()
    CleanResolutionSystem
    If Not m_blnAcceptClass Then
        DestroySocket
    End If
    modSocketMaster.FinalizeProcesses
    Set m_colWaitingResolutions = Nothing
End Sub
Private Sub CleanResolutionSystem()
Dim varAsynHandle As Variant
    For Each varAsynHandle In m_colWaitingResolutions
        api_WSACancelAsyncRequest varAsynHandle
        modSocketMaster.UnregisterResolution varAsynHandle
    Next varAsynHandle
    FreeMemory
End Sub
Public Sub CloseSck()
    If Not m_lngSocketHandle = INVALID_SOCKET Then
        m_enmState = sckClosing
        CleanResolutionSystem
        DestroySocket