csocketmaster.cls

用VB编写的一个小程序

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 = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'Download by http://www.codefans.net
'Name.......... CSocketMaster
'File.......... CSocketMaster.cls
'Version....... 1.1
'Dependencies.. Requires modSocketMaster.bas code module
'Description... Winsock api implementation class
'Author........ Emiliano Scavuzzo <[e-mail]>
'Date.......... February, 22nd 2004

'Copyright (c) 2004 by Emiliano Scavuzzo
'Rosario, Argentina
'
'Based on CSocket by Oleg Gdalevich
'Subclassing based on WinSubHook2 by Paul Caton <[e-mail]>
'
'********************************************************************************

Option Explicit

'==============================================================================
'API FUNCTIONS
'==============================================================================

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

'==============================================================================
'CONSTANTS
'==============================================================================
Public Enum SockState
    sckClosed = 0
    sckOpen
    sckListening
    sckConnectionPending
    sckResolvingHost
    sckHostResolved
    sckConnecting
    sckConnected
    sckClosing
    sckError
End Enum

Public Enum DestResolucion 'asynchronic host resolution destination
    destConnect = 0
    'destSendUDP = 1
End Enum

Private Const SOMAXCONN As Long = 5
Private Const ShowDebug As Boolean = False
Public Enum ProtocolConstants
    sckTCPProtocol = 0
    sckUDPProtocol = 1
End Enum

Private Const MSG_PEEK  As Long = &H2

'==============================================================================
'EVENTS
'==============================================================================

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)

'==============================================================================
'MEMBER VARIABLES
'==============================================================================
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

'  ****  WARNING WARNING WARNING WARNING ******
'This sub MUST be the first on the class. DO NOT attempt
'to change it's location or the code will CRASH.
'This sub receives system messages from our WndProc.
Public Sub WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
Select Case uMsg

Case RESOLVE_MESSAGE
    
    PostResolution wParam, HiWord(lParam)
    
Case SOCKET_MESSAGE
    
    PostSocket LoWord(lParam), HiWord(lParam)
    
End Select
End Sub

Private Sub Class_Initialize()
'socket's handle default value
m_lngSocketHandle = INVALID_SOCKET

'initiate resolution collection
Set m_colWaitingResolutions = New Collection

'initiate processes and winsock service
modSocketMaster.InitiateProcesses
End Sub

Private Sub Class_Terminate()
'clean hostname resolution system
CleanResolutionSystem

'destroy socket if it exists
If Not m_blnAcceptClass Then DestroySocket

'clean processes and finish winsock service
modSocketMaster.FinalizeProcesses

'clean resolution collection
Set m_colWaitingResolutions = Nothing
End Sub

'==============================================================================
'PROPERTIES
'==============================================================================

Public Property Get RemotePort() As Long
RemotePort = m_lngRemotePort
End Property

Public Property Let RemotePort(ByVal lngPort As Long)
If m_enmProtocol = sckTCPProtocol And m_enmState <> sckClosed Then
    Err.Raise sckInvalidOp, "CSocketMaster.RemotePort", "Invalid operation at current state"
End If

If lngPort < 0 Or lngPort > 65535 Then
    Err.Raise sckInvalidArg, "CSocketMaster.RemotePort", "The argument passed to a function was not in the correct format or in the specified range."
Else
    m_lngRemotePort = lngPort
End If
End Property

Public Property Get RemoteHost() As String
RemoteHost = m_strRemoteHost
End Property

Public Property Let RemoteHost(ByVal strHost As String)
If m_enmProtocol = sckTCPProtocol And m_enmState <> sckClosed Then
    Err.Raise sckInvalidOp, "CSocketMaster.RemoteHost", "Invalid operation at current state"
End If

m_strRemoteHost = strHost
End Property

Public Property Get RemoteHostIP() As String
RemoteHostIP = m_strRemoteHostIP
End Property

Public Property Get LocalPort() As Long
If m_lngLocalPortBind = 0 Then
    LocalPort = m_lngLocalPort
Else
    LocalPort = m_lngLocalPortBind
End If
End Property

Public Property Let LocalPort(ByVal lngPort As Long)
If m_enmState <> sckClosed Then
    Err.Raise sckInvalidOp, "CSocketMaster.LocalPort", "Invalid operation at current state"
End If
If lngPort < 0 Or lngPort > 65535 Then
    Err.Raise sckInvalidArg, "CSocketMaster.LocalPort", "The argument passed to a function was not in the correct format or in the specified range."
Else
    m_lngLocalPort = lngPort
End If
End Property

Public Property Get State() As SockState
State = m_enmState
End Property

Public Property Get LocalHostName() As String
LocalHostName = GetLocalHostName
End Property

Public Property Get LocalIP() As String
If m_enmState = sckOpen Or m_enmState = sckListening Then
    LocalIP = m_strLocalIP
Else
    LocalIP = GetLocalIP
End If
End Property

Public Property Get BytesReceived() As Long
If m_enmProtocol = sckTCPProtocol Then
    BytesReceived = Len(m_strRecvBuffer)
Else
    BytesReceived = GetBufferLenUDP
End If
End Property

Public Property Get SocketHandle() As Long
SocketHandle = m_lngSocketHandle
End Property

Public Property Get Tag() As String
Tag = m_strTag
End Property

Public Property Let Tag(ByVal strTag As String)
m_strTag = strTag
End Property

Public Property Get Protocol() As ProtocolConstants
Protocol = m_enmProtocol
End Property

Public Property Let Protocol(ByVal enmProtocol As ProtocolConstants)
If m_enmState <> sckClosed Then
    Err.Raise sckInvalidOp, "CSocketMaster.Protocol", "Invalid operation at current state"
Else
    m_enmProtocol = enmProtocol
End If
End Property

'Destroys the socket if it exists and unregisters it
'from control list.
Private Sub DestroySocket()
If Not m_lngSocketHandle = INVALID_SOCKET Then

    Dim lngResult As Long
    
    lngResult = api_closesocket(m_lngSocketHandle)
    
    If lngResult = SOCKET_ERROR Then
        
        m_enmState = sckError: If ShowDebug Then Debug.Print "STATE: sckError"
        Dim lngErrorCode As Long
        lngErrorCode = Err.LastDllError
        Err.Raise lngErrorCode, "CSocketMaster.DestroySocket", GetErrorDescription(lngErrorCode)
    
    Else
        
        If ShowDebug Then Debug.Print "OK Destroyed socket " & m_lngSocketHandle
        modSocketMaster.UnregisterSocket m_lngSocketHandle
        m_lngSocketHandle = INVALID_SOCKET
    
    End If
    
End If
End Sub

Public Sub CloseSck()
If m_lngSocketHandle = INVALID_SOCKET Then Exit Sub

m_enmState = sckClosing: If ShowDebug Then Debug.Print "STATE: sckClosing"
CleanResolutionSystem
DestroySocket
     
m_lngLocalPortBind = 0
m_strRemoteHostIP = ""
m_strRecvBuffer = ""
m_strSendBuffer = ""
m_lngSendBufferLen = 0
m_lngRecvBufferLen = 0

m_enmState = sckClosed: If ShowDebug Then Debug.Print "STATE: sckClosed"

End Sub

'Tries to create a socket if there isn't one yet and registers
'it to the control list.
'Returns TRUE if it has success
Private Function SocketExists() As Boolean
SocketExists = True
Dim lngResult As Long
Dim lngErrorCode As Long

'check if there is a socket already
If m_lngSocketHandle = INVALID_SOCKET Then
    
    'decide what kind of socket we are creating, TCP or UDP
    If m_enmProtocol = sckTCPProtocol Then
        lngResult = api_socket(AF_INET, SOCK_STREAM, IPPROTO_TCP)
    Else
        lngResult = api_socket(AF_INET, SOCK_DGRAM, IPPROTO_UDP)
    End If
    
    If lngResult = INVALID_SOCKET Then
        
        m_enmState = sckError: If ShowDebug Then Debug.Print "STATE: sckError"
        If ShowDebug Then Debug.Print "ERROR trying to create socket"
        SocketExists = False
        lngErrorCode = Err.LastDllError
        Dim blnCancelDisplay As Boolean
        blnCancelDisplay = True
        RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SocketExists", "", 0, blnCancelDisplay)
        If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SocketExists"
    Else
        
        If ShowDebug Then Debug.Print "OK Created socket: " & lngResult
        m_lngSocketHandle = lngResult
        'set and get some socket options
        ProcessOptions
        SocketExists = modSocketMaster.RegisterSocket(m_lngSocketHandle, ObjPtr(Me), True)
    
    End If
End If
End Function

'Tries to connect to RemoteHost if it was passed, or uses
'm_strRemoteHost instead. If it is a hostname tries to
'resolve it first.
Public Sub Connect(Optional RemoteHost As Variant, Optional RemotePort As Variant)
If m_enmState <> sckClosed Then
    Err.Raise sckInvalidOp, "CSocketMaster.Connect", "Invalid operation at current state"
End If

If Not IsMissing(RemoteHost) Then
        m_strRemoteHost = CStr(RemoteHost)
End If

'for some reason we get a GPF if we try to
'resolve a null string, so we replace it with
'an empty string
If m_strRemoteHost = vbNullString Then
    m_strRemoteHost = ""
End If

'check if RemotePort is a number between 1 and 65535
If Not IsMissing(RemotePort) Then
    If IsNumeric(RemotePort) Then
        If CLng(RemotePort) > 65535 Or CLng(RemotePort) < 1 Then
            Err.Raise sckInvalidArg, "CSocketMaster.Connect", "The argument passed to a function was not in the correct format or in the specified range."
        Else
            m_lngRemotePort = CLng(RemotePort)
        End If
    Else
        Err.Raise sckUnsupported, "CSocketMaster.Connect", "Unsupported variant type."
    End If
End If

'create a socket if there isn't one yet
If Not SocketExists Then Exit Sub

'If we are using UDP we just bind the socket and exit
'silently. Remember UDP is a connectionless protocol.
If m_enmProtocol = sckUDPProtocol Then
    If BindInternal Then
        m_enmState = sckOpen: If ShowDebug Then Debug.Print "STATE: sckOpen"
    End If
    Exit Sub
End If

'try to get a 32 bits long that is used to identify a host
Dim lngAddress As Long
lngAddress = ResolveIfHostname(m_strRemoteHost, destConnect)

'We've got two options here:
'1) m_strRemoteHost was an IP, so a resolution wasn't
'   necessary, and now lngAddress is a 32 bits long and
'   we proceed to connect.
'2) m_strRemoteHost was a hostname, so a resolution was
'   necessary and it's taking place right now. We leave
'   silently.

If lngAddress <> vbNull Then
    ConnectToIP lngAddress, 0
End If

End Sub

'When the system resolves a hostname in asynchronous way we
'call this function to decide what to do with the result.
Private Sub PostResolution(ByVal lngAsynHandle As Long, ByVal lngErrorCode As Long)
If m_enmState <> sckResolvingHost Then Exit Sub

Dim enmDestination As DestResolucion

'find out what the resolution destination was
enmDestination = m_colWaitingResolutions.Item("R" & lngAsynHandle)
'erase that record from the collection since we won't need it any longer
m_colWaitingResolutions.Remove "R" & lngAsynHandle

If lngErrorCode = 0 Then 'if there weren't errors trying to resolve the hostname