用WINSOCK API實現同步非阻塞方式的網絡通訊

    前面寫了基於SELECT實現的同步阻塞方式的網絡通訊，本文將基於EVENT，用代碼描述實現同步非阻塞方式的網絡通訊。相對於同步阻塞方式來說，同步非阻塞方式可以讓更好地讓系統有時間處理一些其它動作，比如進度條繪製，雖然同步阻塞方式也可以，但效果比不上非阻塞的。需要明確的是，阻塞和非阻塞是指網絡套接字與操作系統底層的網絡緩衝區（非套接字緩衝區）之間的通訊方式，使用了EVENT方式，會自動將此方式置非阻塞。好了，俺只講這麼多，具體的見代碼註釋：

Option Base 0 Option Explicit '* ************************************************** * '* 模塊名稱：Winsocket.cls '* 模塊功能：基於API方式的socket同步非阻塞通訊類 '* 編碼：lyserver '* 聯繫方式：http://blog.csdn.net/lyserver '* ************************************************** * '---------------------------------------------------- ' Winsock API相關聲明 '---------------------------------------------------- Private Const SOCKET_ERROR = -1 Private Const INVALID_SOCKET = -1 Private Const WSA_WAIT_FAILED = -1 Private Const WAIT_OBJECT_0 = 0 Private Const WSA_WAIT_EVENT_0 = 0 Private Const WSA_WAIT_TIMEOUT = &H102 Private Const WSAEWOULDBLOCK = 10035 Private Const WSAECONNABORTED = 10053 Public Enum ProtocolConstants IPPROTO_TCP = 6 IPPROTO_UDP = 17 End Enum Private Const INADDR_ANY = &H0 Private Const INADDR_NONE = -1 Private Const SOCK_STREAM = 1 Private Const SOCK_DGRAM = 2 Private Const AF_INET = 2 Private Const O_NONBLOCK = &H4 Private Const FD_NONE = &H0 Private Const FD_READ = &H1 Private Const FD_WRITE = &H2 Private Const FD_ACCEPT = &H8 Private Const FD_CONNECT = &H10 Private Const FD_CLOSE = &H20 Private Type HostEnt hName As Long hAliases As Long hAddrType As Integer hLength As Integer hAddrList As Long End Type Private Const MAX_WSADescription = 256 Private Const MAX_WSASYSStatus = 128 Private Type WSAData wVersion As Integer wHighVersion As Integer szDescription(MAX_WSADescription - 1) As Byte szSystemStatus(MAX_WSASYSStatus - 1) As Byte wMaxSockets As Long wMaxUDPDG As Long dwVendorInfo As Long End Type Private Type sockaddr sin_family As Integer sin_port As Integer sin_addr As Long sin_zero(7) As Byte End Type Private Const FD_MAX_EVENTS = 10 Private Type WSANETWORKEVENTS lNetworkEvents As Long iErrorCode(FD_MAX_EVENTS - 1) As Long End Type Private Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVersion As Long, lpWSAD As WSAData) As Long Private Declare Function WSACleanup Lib "ws2_32.dll" () As Long Private Type WSAOVERLAPPED Internal As Long InternalHigh As Long Offset As Long OffsetHigh As Long hEvent As Long End Type Private Type WSABUF Length As Long pszBuf As Long End Type Private Declare Function WSASend Lib "ws2_32.dll" (ByVal s As Long, ByRef lpBuffers As WSABUF, ByVal dwBufferCount As Long, ByRef lpNumberOfBytesSent As Long, ByVal dwFlags As Long, lpOverlapped As WSAOVERLAPPED, ByVal lpCompletionRoutine As Long) As Long Private Const WSA_IO_PENDING = 997 Private Declare Function WSARecv Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef lpBuffers As WSABUF, ByVal dwBufferCount As Long, ByRef lpNumberOfBytesRecvd As Long, ByRef lpFlags As Long, ByRef lpOverlapped As WSAOVERLAPPED, ByVal lpCompletionRoutine As Long) As Long Private Declare Function WSAGetOverlappedResult Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef lpOverlapped As WSAOVERLAPPED, ByVal lpcbTransfer As Long, ByVal fWait As Long, ByRef lpdwFlags As Long) As Long Private Const FD_SETSIZE = 64 Private Type fd_set fd_count As Long fd_array(63) As Long End Type Private Type timeval tv_sec As Long tv_usec As Long End Type Private Declare Function WSAEventSelect Lib "ws2_32.dll" (ByVal s As Long, ByVal hEventObject As Long, ByVal lNetworkEvents As Long) As Long Private Declare Function WSACreateEvent Lib "ws2_32.dll" () As Long Private Declare Function WSAResetEvent Lib "ws2_32.dll" (ByVal hEvent As Long) As Long Private Declare Function WSASetEvent Lib "ws2_32.dll" (ByVal hEvent As Long) As Long Private Declare Function WSACloseEvent Lib "ws2_32.dll" (ByVal hEvent As Long) As Long Private Declare Function WSAGetLastError Lib "ws2_32" () As Long Private Declare Function WSAEnumNetworkEvents Lib "ws2_32.dll" (ByVal s As Long, ByVal hEventOjbect As Long, lpNetWorkEvents As WSANETWORKEVENTS) As Long Private Declare Function WSAWaitForMultipleEvents Lib "ws2_32.dll" (ByVal cEvents As Long, ByRef lphEvents As Long, ByVal fWaitAll As Boolean, ByVal dwTimeout As Long, ByVal fAlertable As Boolean) As Long Private Declare Function WSAIsBlocking Lib "ws2_32.dll" () As Long Private Declare Function WSACancelBlockingCall Lib "ws2_32.dll" () As Long Private Declare Function socket Lib "ws2_32.dll" (ByVal af As Long, ByVal s_type As Long, ByVal protocal As Long) As Long Private Declare Function selectAPI Lib "ws2_32" Alias "select" (ByVal nfds As Long, ByVal readfds As Long, ByVal wrITefds As Long, ByVal exceptfds As Long, timeout As timeval) As Long Private Declare Function bindAPI Lib "ws2_32.dll" Alias "bind" (ByVal s As Long, addr As sockaddr, ByVal namelen As Long) As Long Private Declare Function listenAPI Lib "ws2_32.dll" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As Integer Private Declare Function acceptAPI Lib "ws2_32.dll" Alias "accept" (ByVal s As Long, ByRef addr As sockaddr, ByRef namelen As Long) As Long Private Declare Function closesocket Lib "ws2_32.dll" (ByVal s As Integer) As Integer Private Declare Function connectAPI Lib "ws2_32.dll" Alias "connect" (ByVal s As Long, ByRef Name As sockaddr, ByVal namelen As Long) As Long Private Declare Function recv Lib "ws2_32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long Private Declare Function Send Lib "ws2_32.dll" Alias "send" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long Private Declare Function htons Lib "ws2_32.dll" (ByVal hostshort As Long) As Integer Private Const TCP_NODELAY = &H1& Private Const SO_LINGER = &H80& Private Type LINGER_STRUCT l_onoff As Integer l_linger As Integer End Type Private Const SO_MAX_MSG_SIZE As Long = &H2003 Private Const SOL_SOCKET = 65535 Private Const SO_SNDBUF = &H1001 ' Send buffer size. Private Const SO_RCVBUF = &H1002 Private Const SO_SNDTIMEO = &H1005 Private Const SO_RCVTIMEO = &H1006 Private 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 Private 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 Private Const FIONBIO = &H8004667E Private Const FIOASYNC = &H8004667D Private Declare Function ioctlsocket Lib "ws2_32.dll" (ByVal s As Long, ByVal cmd As Long, argp As Long) As Long Private Declare Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long Private Declare Function inet_ntoa Lib "wsock32.dll" (ByVal addr As Long) As Long Private Declare Function gethostname Lib "ws2_32.dll" (ByVal szHost As String, ByVal dwHostLen As Long) As Long Private Declare Function gethostbyname Lib "ws2_32.dll" (ByVal hostname As String) As Long '---------------------------------------------------- ' ICMP協議API相關聲明 '---------------------------------------------------- Private Type ICMP_ECHO_REPLY Address As Long Status As Long RoundTripTime As Long DataSize As Long Reserved As Integer ptrData As Long Options(7) As Byte Data As String * 250 End Type Private Const ICMP_SUCCESS = 0 Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long Private Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, ByVal DestinationAddress As Long, ByVal RequestData As String, ByVal RequestSize As Long, ByVal RequestOptions As Long, ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long, ByVal timeout As Long) As Long Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long '---------------------------------------------------- ' 輔助API聲明 '---------------------------------------------------- Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Const QS_HOTKEY = &H80 Private Const QS_KEY = &H1 Private Const QS_MOUSEBUTTON = &H4 Private Const QS_MOUSEMOVE = &H2 Private Const QS_PAINT = &H20 Private Const QS_POSTMESSAGE = &H8 Private Const QS_SENDMESSAGE = &H40 Private Const QS_TIMER = &H10 Private Const QS_ALLINPUT = (QS_SENDMESSAGE Or QS_PAINT Or QS_TIMER Or QS_POSTMESSAGE Or QS_MOUSEBUTTON Or QS_MOUSEMOVE Or QS_HOTKEY Or QS_KEY) Private Const QS_MOUSE = (QS_MOUSEMOVE Or QS_MOUSEBUTTON) Private Const QS_INPUT = (QS_MOUSE Or QS_KEY) Private Const QS_ALLEVENTS = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY) Private Declare Function GetQueueStatus Lib "user32" (ByVal qsFlags As Long) As Long Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByRef saArray() As Any) As Long Private Declare Function GetTickCount Lib "kernel32" () As Long Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '---------------------------------------------------- ' 類錯誤常量聲明 '---------------------------------------------------- Public Enum skcErrorConstants sckInvalidAddress = 1001 skcConnectTimeout = 1002 sckSendTimeout = 1003 sckRecvTimeout = 1004 sckDisconnect = 1005 End Enum '---------------------------------------------------- ' 類事件聲明 '---------------------------------------------------- Public Event OnSending(ByVal TotalBytes As Long, ByVal SentBytes As Long, ByRef Cancel As Boolean) Public Event OnError(ByVal lngErrorCode As skcErrorConstants, ByVal strDescription As String) '---------------------------------------------------- ' 類屬性變量聲明 '---------------------------------------------------- Dim m_lngProtocol As ProtocolConstants '---------------------------------------------------- ' 用戶自定義模塊變量 '---------------------------------------------------- Dim m_blnCancel As Boolean '是否中止標誌 Dim m_blnBusy As Boolean '套接字是否處於Busy狀態 Dim m_blnInitial As Boolean 'Winsock函數庫初始化標誌 Dim m_hSocket As Long '套接字句柄 Dim m_hEvent As Long '套接字事件監聽對象句柄 Dim m_lngEvents As Long '套接字事件代碼 Dim SEND_BUFFER_SIZE As Long '套接字發送緩衝區大小 Dim RECV_BUFFER_SIZE As Long '套接字接收緩衝區大小 '---------------------------------------------------- ' 函數功能：類初始化 '---------------------------------------------------- Private Sub Class_Initialize() Dim WSAD As WSAData Dim lngVersionRequested As Long '初始化SOCKET函數庫 lngVersionRequested = &H202 WSAStartup lngVersionRequested, WSAD m_blnInitial = (WSAD.wVersion = lngVersionRequested) '初始化默認通訊協議 m_lngProtocol = IPPROTO_TCP '設置套接字默認值 m_hSocket = INVALID_SOCKET End Sub '---------------------------------------------------- ' 函數功能：類被銷燬 '---------------------------------------------------- Private Sub Class_Terminate() Disconnect WSACleanup End Sub '---------------------------------------------------- ' 屬性功能：獲得和設置通訊協議 ' 參數說明：無 '---------------------------------------------------- Public Property Get Protocol() As ProtocolConstants Protocol = m_lngProtocol End Property Public Property Let Protocol(ByVal New_Value As ProtocolConstants) m_lngProtocol = New_Value End Property '---------------------------------------------------- ' 屬性功能：獲得和設置發送緩衝區大小 ' 參數說明：無 '---------------------------------------------------- Public Property Get SendBufferSize() As Long SendBufferSize = SEND_BUFFER_SIZE End Property Public Property Let SendBufferSize(ByVal New_Value As Long) If New_Value < 512 Or New_Value > 65536 Then Exit Property SEND_BUFFER_SIZE = New_Value setsockopt m_hSocket, SOL_SOCKET, SO_SNDBUF, SEND_BUFFER_SIZE, Len(SEND_BUFFER_SIZE) End Property '---------------------------------------------------- ' 屬性功能：獲得和設置接收緩衝區大小 ' 參數說明：無 '---------------------------------------------------- Public Property Get RecvBufferSize() As Long RecvBufferSize = RECV_BUFFER_SIZE End Property Public Property Let RecvBufferSize(ByVal New_Value As Long) If New_Value < 512 Or New_Value > 65536 Then Exit Property RECV_BUFFER_SIZE = New_Value setsockopt m_hSocket, SOL_SOCKET, SO_RCVBUF, RECV_BUFFER_SIZE, Len(RECV_BUFFER_SIZE) End Property '---------------------------------------------------- ' 函數功能：建立網絡連接(僅用於客戶端) ' 參數說明：strRemoteHost服務器IP或域名，intRemotePort服務器端口 ' 返 回 值：返回數據接收套接字索引，-1爲失敗 '---------------------------------------------------- Public Function Connect(ByVal strRemoteHost As String, ByVal intRemotePort As Integer) As Boolean Dim s_addr As sockaddr If Not m_blnInitial Then Exit Function '如果未成功初始化Winsock庫則退出 If m_hSocket <> INVALID_SOCKET Or m_blnBusy Then Exit Function '如果套接字已創建或處於Busy狀態則退出 If Len(strRemoteHost) = 0 Then Exit Function '如果沒有指定遠程服務器地址則退出 '填充s_addr s_addr.sin_family = AF_INET s_addr.sin_addr = DomainToIp(strRemoteHost) If s_addr.sin_addr = INADDR_NONE Then '如果地址錯誤，則拋出錯誤事件並退出連接 RaiseEvent OnError(sckInvalidAddress, "非法的IP地址或通訊端口!") Exit Function End If s_addr.sin_port = htons(intRemotePort) '創建套接字 m_blnBusy = True m_hSocket = socket(AF_INET, SOCK_STREAM, m_lngProtocol) '創建事件監聽對象，並綁定到套接字上 m_hEvent = WSACreateEvent() WSAEventSelect m_hSocket, m_hEvent, FD_CONNECT Or FD_READ Or FD_WRITE Or FD_CLOSE connectAPI m_hSocket, s_addr, Len(s_addr) If CheckStatus(FD_CONNECT) Then '如果連接成功 getsockopt m_hSocket, SOL_SOCKET, SO_SNDBUF, SEND_BUFFER_SIZE, Len(SEND_BUFFER_SIZE) '獲得發送緩衝區大小 getsockopt m_hSocket, SOL_SOCKET, SO_RCVBUF, RECV_BUFFER_SIZE, Len(RECV_BUFFER_SIZE) '獲得接收緩衝區大小 Connect = True '設置連接成功標誌 Else RaiseEvent OnError(skcConnectTimeout, "網絡連接超時!") Disconnect End If m_blnBusy = False End Function '---------------------------------------------------- ' 函數功能：斷開網絡連接。 ' 參數說明：無 ' 返 回 值：True成功斷開，False失敗 '---------------------------------------------------- Public Function Disconnect() As Boolean If m_hSocket <> INVALID_SOCKET And (Not m_blnBusy) Then m_lngEvents = 0 m_blnCancel = False WSAEventSelect m_hSocket, 0, 0 closesocket m_hSocket '關閉連接 WSACloseEvent m_hEvent '關閉監聽對象 m_hSocket = INVALID_SOCKET '設置套接字默認值 Disconnect = True End If End Function '---------------------------------------------------- ' 函數功能：讀取接收到的數據 ' 參數說明：varData數據接收緩衝區，可爲字節串或字節數組 ' 返 回 值：True表示成功，False表示失敗 '---------------------------------------------------- Public Function GetData(ByRef varData As Variant, Optional ByVal lngTimeout As Long = 10000) As Boolean Dim i As Long Dim lngRet As Long Dim bytData() As Byte If m_hSocket = INVALID_SOCKET Or m_blnBusy Then Exit Function '如果套接字無效或處於忙狀態則退出 '讀取數據 If Not CheckStatus(FD_READ, lngTimeout) Then Exit Function '如果套接字不可讀則退出循環 ReDim bytData(RECV_BUFFER_SIZE - 1) '初始化接收緩衝區 lngRet = recv(m_hSocket, bytData(0), RECV_BUFFER_SIZE, 0) '讀取數據 If lngRet > 0 Then ReDim Preserve bytData(lngRet - 1) If VarType(varData) = vbString Then varData = StrConv(bytData, vbUnicode) Else varData = bytData End If GetData = True Else Erase bytData End If End Function '---------------------------------------------------- ' 函數功能：發送數據。 ' 參數說明：Data需要發送的數據，可爲字符串或字節數組 ' 返 回 值：True表示成功，False表示失敗 '---------------------------------------------------- Public Function SendData(ByRef varData As Variant, Optional ByVal lngTimeout As Long = 10000) As Boolean Dim bytData() As Byte Dim lngRet As Long Dim lngDataSize As Long Dim lngBlockSize As Long Dim i As Long If m_hSocket = INVALID_SOCKET Or m_blnBusy Then Exit Function '如果套接字無效或處於忙狀態則退出 '將需要發送的數據轉換爲字節數組 Select Case VarType(varData) Case vbString bytData = StrConv(varData, vbFromUnicode) Case (vbByte Or vbArray) bytData = varData Case Else Exit Function End Select '數據爲空時無需發送 If SafeArrayGetDim(bytData) = 0 Then Exit Function m_blnBusy = True '數據分塊發送 lngDataSize = UBound(bytData) + 1 '需要發送的數據總數量 For i = 0 To lngDataSize - 1 Step SEND_BUFFER_SIZE '如果用戶中斷髮送則退出 If m_blnCancel Then Exit For '計算分塊後待發數據的數量 lngBlockSize = lngDataSize - i If lngBlockSize > SEND_BUFFER_SIZE Then lngBlockSize = SEND_BUFFER_SIZE '檢查網絡是否可寫 CheckStatus FD_WRITE, 60000 '如果用戶中斷髮送則退出 If m_blnCancel Then Exit For '發送數據 lngRet = Send(m_hSocket, bytData(i), lngBlockSize, 0) If lngRet = SOCKET_ERROR Then '出錯重發 If WSAGetLastError() = WSAEWOULDBLOCK Then If Not CheckStatus(FD_WRITE, 60000) Then Exit For '套接字不可寫則退出數據發送 lngRet = Send(m_hSocket, bytData(i), lngBlockSize, 0) '發送數據 End If ElseIf lngRet = lngBlockSize Then '數據發送成功 RaiseEvent OnSending(lngDataSize, i + lngBlockSize, m_blnCancel) '拋出數據發送事件 If lngBlockSize = lngDataSize - i Then m_lngEvents = (m_lngEvents Or FD_WRITE) Exit For End If Else '數據發送失敗 Debug.Print WSAIsBlocking() RaiseEvent OnError(sckSendTimeout, "數據發送超時!") Exit Function End If If GetQueueStatus(QS_MOUSE Or QS_KEY Or QS_PAINT) Then DoEvents '轉讓控制權 Next SendData = ((lngRet = lngBlockSize) And (m_blnCancel = False)) m_blnCancel = False '重置中止狀態 m_blnBusy = False '設置狀態爲空閒 End Function '---------------------------------------------------- ' 函數功能：中止網絡操作 ' 參數說明：無 ' 返 回 值：無 '---------------------------------------------------- Public Sub Cancel() m_blnCancel = True '設置中止狀態 End Sub '---------------------------------------------------- ' 函數功能：輔助函數，將或名轉換爲IP ' 參數說明：strHost服務器名稱或IP地址，如果爲空表示本地計算機。 ' 返 回 值：32位的IP值，如果域名有多個IP，只返回第一個 '---------------------------------------------------- Private Function DomainToIp(Optional ByVal strHost As String) As Long Dim lpHostent As Long, lpIpList As Long, lngIp As Long Dim udtHostent As HostEnt If Not m_blnInitial Then Exit Function '如果未成功初始化Winsock庫則退出 lngIp = INADDR_NONE strHost = Trim(strHost) If Len(strHost) = 0 Then strHost = String(100, vbNullChar) gethostname strHost, Len(strHost) '獲得本地計算機名稱 strHost = Left(strHost, InStr(strHost, vbNullChar) - 1) Else lngIp = inet_addr(strHost) If lngIp <> INADDR_NONE Then 'strHost參數值爲IP地址 DomainToIp = lngIp Exit Function End If End If lpHostent = gethostbyname(strHost & vbNullChar) '根據域名獲得IP If lpHostent <> 0 Then CopyMemory udtHostent, ByVal lpHostent, LenB(udtHostent) CopyMemory lpIpList, ByVal udtHostent.hAddrList, 4 CopyMemory lngIp, ByVal lpIpList, 4 '當域名有多個IP地址時，只取第一個IP DomainToIp = lngIp End If End Function '---------------------------------------------------- ' 函數功能：輔助函數，檢查套接字指定的狀態是否準備就緒 ' 參數說明：lMask需檢測的狀態掩碼，lngTimeout超時(單位爲毫秒) ' 返 回 值：True表示就緒，False表示未就緒 '---------------------------------------------------- Private Function CheckStatus(ByRef lMask As Long, Optional ByRef lngTimeout As Long = 10000) As Boolean Dim lngRet As Long Dim lngStartTime As Long Dim udtEvent As WSANETWORKEVENTS If (m_lngEvents And lMask) = 0 Then lngStartTime = GetTickCount() Do lngRet = WSAWaitForMultipleEvents(1, m_hEvent, False, 100, False) If lngRet = 0 Then WSAEnumNetworkEvents m_hSocket, m_hEvent, udtEvent m_lngEvents = (m_lngEvents Or udtEvent.lNetworkEvents) Exit Do End If DoEvents '轉讓控制權 Loop Until m_blnCancel Or GetTickCount() - lngStartTime > lngTimeout End If m_blnCancel = False '重置中止狀態 If (m_lngEvents And lMask) = lMask Then m_lngEvents = (m_lngEvents Xor lMask) CheckStatus = True End If End Function