用WINSOCK API实现同步阻塞方式的网络通讯

 在VB中进行网络通讯时，一般都爱使用Winsock控件，但此控件有两点缺点，一是需要一个窗口（当然也可以修改vbp文件，实现无窗口加载Winsock控件），二是通讯方式为异步非阻塞的，对于某些基于应答式的协议来说，比如HTTP、POP3、SMPT等，使用阻塞方式往往要方便得多，而且代码流程也清晰得多，增强了可读性，更不用说灵活性了（比如超时设置、缓冲区设置等）。虽然网络上有一些使用API编写的通讯类，但大类使用了WSAAsyncSelect方式，完全是Winsock的API版本，根本没啥意义，而且有的代码还不能很好地运行，为此，我使用API基于SELECT方式编写了一个同步阻塞方式的客户端通讯类，用来处理应答式网络协议，在实际工作中，取得了很好的效果，现将代码公布如下：

Option Base 0Option Explicit'* ************************************************** *'* 模块名称：Winsocket.cls'* 模块功能：基于API方式的socket同步阻塞通讯类'* 编码：lyserver'* 联系方式：http://blog.csdn.net/lyserver'* ************************************************** *'----------------------------------------------------' Winsock API相关声明'----------------------------------------------------Private Const SOCKET_ERROR = -1Private Const INVALID_SOCKET = -1Private Const WSA_WAIT_FAILED = -1Private Const WAIT_OBJECT_0 = 0Private Const WSA_WAIT_EVENT_0 = 0Private Const WSA_WAIT_TIMEOUT = &H102Private Const WSAEWOULDBLOCK = 10035Private Const WSAECONNABORTED = 10053Public Enum ProtocolConstants IPPROTO_TCP = 6 IPPROTO_UDP = 17End EnumPrivate Const INADDR_ANY = &H0Private Const INADDR_NONE = -1Private Const SOCK_STREAM = 1Private Const SOCK_DGRAM = 2Private Const AF_INET = 2Private Const O_NONBLOCK = &H4Private Const FD_NONE = &H0Private Const FD_READ = &H1Private Const FD_WRITE = &H2Private Const FD_ACCEPT = &H8Private Const FD_CONNECT = &H10Private Const FD_CLOSE = &H20Private Type HostEnt hName As Long hAliases As Long hAddrType As Integer hLength As Integer hAddrList As LongEnd TypePrivate Const MAX_WSADescription = 256Private Const MAX_WSASYSStatus = 128Private 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 LongEnd TypePrivate Type sockaddr sin_family As Integer sin_port As Integer sin_addr As Long sin_zero(7) As ByteEnd TypePrivate Const FD_MAX_EVENTS = 10Private Type WSANETWORKEVENTS lNetworkEvents As Long iErrorCode(FD_MAX_EVENTS - 1) As LongEnd TypePrivate Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVersion As Long, lpWSAD As WSAData) As LongPrivate Declare Function WSACleanup Lib "ws2_32.dll" () As LongPrivate Type WSAOVERLAPPED Internal As Long InternalHigh As Long Offset As Long OffsetHigh As Long hEvent As LongEnd TypePrivate Type WSABUF Length As Long pszBuf As LongEnd TypePrivate 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 LongPrivate Const WSA_IO_PENDING = 997Private 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 LongPrivate 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 LongPrivate Const FD_SETSIZE = 64Private Type fd_set fd_count As Long fd_array(63) As LongEnd TypePrivate Type timeval tv_sec As Long tv_usec As LongEnd TypePrivate Declare Function WSAEventSelect Lib "ws2_32.dll" (ByVal s As Long, ByVal hEventObject As Long, ByVal lNetworkEvents As Long) As LongPrivate Declare Function WSACreateEvent Lib "ws2_32.dll" () As LongPrivate Declare Function WSAResetEvent Lib "ws2_32.dll" (ByVal hEvent As Long) As LongPrivate Declare Function WSASetEvent Lib "ws2_32.dll" (ByVal hEvent As Long) As LongPrivate Declare Function WSACloseEvent Lib "ws2_32.dll" (ByVal hEvent As Long) As LongPrivate Declare Function WSAGetLastError Lib "ws2_32" () As LongPrivate Declare Function WSAEnumNetworkEvents Lib "ws2_32.dll" (ByVal s As Long, ByVal hEventOjbect As Long, lpNetWorkEvents As WSANETWORKEVENTS) As LongPrivate 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 LongPrivate Declare Function WSAIsBlocking Lib "ws2_32.dll" () As LongPrivate Declare Function WSACancelBlockingCall Lib "ws2_32.dll" () As LongPrivate Declare Function socket Lib "ws2_32.dll" (ByVal af As Long, ByVal s_type As Long, ByVal protocal As Long) As LongPrivate 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 LongPrivate Declare Function bindAPI Lib "ws2_32.dll" Alias "bind" (ByVal s As Long, addr As sockaddr, ByVal namelen As Long) As LongPrivate Declare Function listenAPI Lib "ws2_32.dll" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As IntegerPrivate Declare Function acceptAPI Lib "ws2_32.dll" Alias "accept" (ByVal s As Long, ByRef addr As sockaddr, ByRef namelen As Long) As LongPrivate Declare Function closesocket Lib "ws2_32.dll" (ByVal s As Integer) As IntegerPrivate Declare Function connectAPI Lib "ws2_32.dll" Alias "connect" (ByVal s As Long, ByRef Name As sockaddr, ByVal namelen As Long) As LongPrivate Declare Function recv Lib "ws2_32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As LongPrivate 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 LongPrivate Declare Function htons Lib "ws2_32.dll" (ByVal hostshort As Long) As IntegerPrivate Const TCP_NODELAY = &H1&Private Const SO_LINGER = &H80&Private Type LINGER_STRUCT l_onoff As Integer l_linger As IntegerEnd TypePrivate Const SO_MAX_MSG_SIZE As Long = &H2003Private Const SOL_SOCKET = 65535Private Const SO_SNDBUF = &H1001 ' Send buffer size.Private Const SO_RCVBUF = &H1002Private Const SO_SNDTIMEO = &H1005Private Const SO_RCVTIMEO = &H1006Private 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 LongPrivate 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 LongPrivate Const FIONBIO = &H8004667EPrivate Const FIOASYNC = &H8004667DPrivate Declare Function ioctlsocket Lib "ws2_32.dll" (ByVal s As Long, ByVal cmd As Long, argp As Long) As LongPrivate Declare Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As LongPrivate Declare Function inet_ntoa Lib "wsock32.dll" (ByVal addr As Long) As LongPrivate Declare Function gethostname Lib "ws2_32.dll" (ByVal szHost As String, ByVal dwHostLen As Long) As LongPrivate 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 * 250End TypePrivate Const ICMP_SUCCESS = 0Private Declare Function IcmpCreateFile Lib "icmp.dll" () As LongPrivate 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 LongPrivate 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 = &H80Private Const QS_KEY = &H1Private Const QS_MOUSEBUTTON = &H4Private Const QS_MOUSEMOVE = &H2Private Const QS_PAINT = &H20Private Const QS_POSTMESSAGE = &H8Private Const QS_SENDMESSAGE = &H40Private Const QS_TIMER = &H10Private 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 LongPrivate Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByRef saArray() As Any) As LongPrivate Declare Function GetTickCount Lib "kernel32" () As LongPrivate Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As LongPrivate Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)'----------------------------------------------------' 类事件定义'----------------------------------------------------Public Event OnConncted()Public Event OnSending(ByVal TotalBytes As Long, ByVal SentBytes As Long, ByRef Cancel As Boolean)Public Event OnReceiving(ByVal ReceivedBytes As Long, ByRef Cancel As Boolean)Public Event OnError(ByVal lngErrorCode As Long, 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 SEND_BUFFER_SIZE As Long '数据发送缓冲区大小Dim RECV_BUFFER_SIZE As Long '数据接收缓冲区大小Dim SEND_TIMEOUT As Long '数据发送超时Dim RECV_TIMEOUT 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_SOCKETEnd Sub'----------------------------------------------------' 函数功能：类被销毁'----------------------------------------------------Private Sub Class_Terminate() Disconnect WSACleanupEnd Sub'----------------------------------------------------' 属性功能：获得和设置通讯协议' 参数说明：无'----------------------------------------------------Public Property Get Protocol() As ProtocolConstants Protocol = m_lngProtocolEnd PropertyPublic Property Let Protocol(ByVal New_Value As ProtocolConstants) m_lngProtocol = New_ValueEnd Property'----------------------------------------------------' 属性功能：获得和设置接收缓冲区大小' 参数说明：无'----------------------------------------------------Public Property Get RecvBufferSize() As Long If m_hSocket <> INVALID_SOCKET Then RecvBufferSize = RECV_BUFFER_SIZEEnd PropertyPublic Property Let RecvBufferSize(ByVal New_Value As Long) If m_hSocket = INVALID_SOCKET Or 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'----------------------------------------------------' 属性功能：获得和设置发送缓冲区大小' 参数说明：无'----------------------------------------------------Public Property Get SendBufferSize() As Long If m_hSocket <> INVALID_SOCKET Then SendBufferSize = SEND_BUFFER_SIZEEnd PropertyPublic Property Let SendBufferSize(ByVal New_Value As Long) If m_hSocket = INVALID_SOCKET Or 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 PropertyPublic Property Get RecvTimeout() As Long If m_hSocket <> INVALID_SOCKET Then RecvTimeout = RECV_TIMEOUTEnd PropertyPublic Property Let RecvTimeout(ByVal New_Value As Long) If m_hSocket = INVALID_SOCKET Or New_Value < 0 Or New_Value > 60000 Then Exit Property RECV_TIMEOUT = New_Value setsockopt m_hSocket, SOL_SOCKET, SO_RCVTIMEO, RECV_TIMEOUT, Len(RECV_TIMEOUT) '设置接收超时End PropertyPublic Property Get SendTimeout() As Long If m_hSocket <> INVALID_SOCKET Then SendTimeout = SEND_TIMEOUTEnd PropertyPublic Property Let SendTimeout(ByVal New_Value As Long) If m_hSocket = INVALID_SOCKET Or New_Value < 0 Or New_Value > 60000 Then Exit Property SEND_TIMEOUT = New_Value setsockopt m_hSocket, SOL_SOCKET, SO_SNDTIMEO, SEND_TIMEOUT, Len(SEND_TIMEOUT) '设置发送超时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 '如果没有指定远程服务器地址则退出 m_blnBusy = True m_hSocket = socket(AF_INET, SOCK_STREAM, m_lngProtocol) '创建套接字 '填充s_addr s_addr.sin_family = AF_INET s_addr.sin_addr = DomainToIp(strRemoteHost) s_addr.sin_port = htons(intRemotePort) '等待连接完成(使用异步方式，超时10秒) Dim blnSuccess As Boolean Dim hEvent As Long, lngStartTime As Long hEvent = WSACreateEvent() WSAEventSelect m_hSocket, hEvent, FD_CONNECT '设置异步连接方式 If connectAPI(m_hSocket, s_addr, Len(s_addr)) = SOCKET_ERROR Then lngStartTime = GetTickCount() Do If WaitForSingleObject(hEvent, 20) = WAIT_OBJECT_0 Then RaiseEvent OnConncted '连接成功，抛出OnConnected事件 blnSuccess = True Exit Do End If DoEvents Loop Until (GetTickCount - lngStartTime > 10000) Or m_blnCancel End If WSAEventSelect m_hSocket, 0, 0 '取消异步方式 WSACloseEvent hEvent If blnSuccess Then '如果连接成功 Dim lngValue As Long 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) '获得接收缓冲区大小 SEND_TIMEOUT = 30000 setsockopt m_hSocket, SOL_SOCKET, SO_SNDTIMEO, SEND_TIMEOUT, Len(SEND_TIMEOUT) '设置发送超时为30秒 RECV_TIMEOUT = 10000 setsockopt m_hSocket, SOL_SOCKET, SO_RCVTIMEO, RECV_TIMEOUT, Len(RECV_TIMEOUT) '设置接收超时为10秒 Connect = True '设置连接成功标志 Else RaiseEvent OnError(-1, "连接失败") Disconnect End If m_blnBusy = FalseEnd Function'----------------------------------------------------' 函数功能：断开网络连接。' 参数说明：无' 返 回 值：True成功断开，False失败'----------------------------------------------------Public Function Disconnect() As Boolean If m_hSocket <> INVALID_SOCKET And (Not m_blnBusy) Then closesocket m_hSocket '关闭连接 m_hSocket = INVALID_SOCKET '设置套接字默认值 Disconnect = True End IfEnd Function'----------------------------------------------------' 函数功能：读取接收到的数据' 参数说明：varData数据接收缓冲区，可为字节串或字节数组' 返 回 值：True表示成功，False表示失败'----------------------------------------------------Public Function GetData(ByRef varData As Variant, Optional ByVal lngTimeout As Long = 5000) As Boolean Dim i As Long Dim bytData() As Byte, bytBuffer() As Byte Dim lngRet As Long Dim lngDataSize As Long If m_hSocket = INVALID_SOCKET Or m_blnBusy Then Exit Function '如果套接字无效或处于忙状态则退出 m_blnBusy = True '设置状态为忙 '循环读取数据，直到把数据读取完毕 lngDataSize = 0 '初始化接收到的数据量 ReDim bytBuffer(RECV_BUFFER_SIZE - 1) '初始化接收缓冲区 '读取数据 Do If Not CheckStatus(FD_READ) Then Exit Do '如果套接字不可读则退出循环 lngRet = recv(m_hSocket, bytBuffer(0), RECV_BUFFER_SIZE, 0) '读取数据 If lngRet > 0 Then '数据读取成功 RaiseEvent OnReceiving(lngDataSize + lngRet, m_blnCancel) '抛出数据接收事件 '合并读到的数据 ReDim Preserve bytData(lngDataSize + lngRet - 1) CopyMemory bytData(lngDataSize), bytBuffer(0), lngRet lngDataSize = lngDataSize + lngRet If lngRet < RECV_BUFFER_SIZE Then Exit Do '如果读取的数据小于缓冲区大小则退出循环 ElseIf lngRet = 0 Then '如果套接字允许读而数据接收为0，说明对方已断开连接 RaiseEvent OnError(-2, "对方已断开连接") Else '否则网络不可靠 If WSAGetLastError() = WSAECONNABORTED Then RaiseEvent OnError(-2, "对方已断开连接") End If If GetQueueStatus(QS_MOUSE Or QS_KEY Or QS_PAINT) Then DoEvents '转让控制权 Loop Until lngRet <= 0 Or m_blnCancel '设置返回值 GetData = SafeArrayGetDim(bytData) If VarType(varData) = vbString Then varData = StrConv(bytData, vbUnicode) Else varData = bytData End If GetData = True m_blnBusy = False '设置状态为空闲End Function'----------------------------------------------------' 函数功能：发送数据。' 参数说明：Data需要发送的数据，可为字符串或字节数组' 返 回 值：True表示成功，False表示失败'----------------------------------------------------Public Function SendData(ByRef varData As Variant, Optional ByVal lngTimeout As Long = 5000) 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 '如果中断则退出 If Not CheckStatus(FD_WRITE) Then Exit For '套接字不可写则退出数据发送 '计算分块后待发数据的数量 lngBlockSize = lngDataSize - i If lngBlockSize > SEND_BUFFER_SIZE Then lngBlockSize = SEND_BUFFER_SIZE lngRet = Send(m_hSocket, bytData(i), lngBlockSize, 0) '发送数据 If lngRet = lngBlockSize Then '数据发送成功 RaiseEvent OnSending(lngDataSize, i + lngBlockSize, m_blnCancel) '抛出数据发送事件 If lngBlockSize = lngDataSize - i Then Exit For Else '数据发送失败 Debug.Print WSAIsBlocking() RaiseEvent OnError(-4, "网络不可靠") Exit Function End If If GetQueueStatus(QS_MOUSE Or QS_KEY Or QS_PAINT) Then DoEvents '转让控制权 Next SendData = (lngRet = lngBlockSize) m_blnBusy = False '设置状态为空闲End Function'----------------------------------------------------' 函数功能：中止网络操作' 参数说明：无' 返 回 值：无'----------------------------------------------------Public Sub Cancel() m_blnCancel = TrueEnd 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 IfEnd Function'----------------------------------------------------' 函数功能：辅助函数，检查套接字指定的状态是否准备就绪' 参数说明：lngStatus需要检测的状态，lngSecond超时，超时单位为秒' 返 回 值：True表示就绪，False表示未就绪'----------------------------------------------------Private Function CheckStatus(ByVal lngStatus As Long, Optional ByVal lngSecond As Long = 60) As Boolean Dim fd As fd_set Dim tmo As timeval Dim lngRet As Long Dim lngStartTime As Long Dim lpReadFD As Long Dim lpWriteFD As Long fd.fd_count = 1 fd.fd_array(0) = m_hSocket tmo.tv_sec = 0 'lngSecond tmo.tv_usec = 1000 * 200& '0 If lngStatus = FD_READ Then lpReadFD = VarPtr(fd) ElseIf lngStatus = FD_WRITE Then lpWriteFD = VarPtr(fd) Else Exit Function End If lngStartTime = GetTickCount() Do lngRet = selectAPI(0, lpReadFD, lpWriteFD, 0, tmo) If lngRet = 0 Then '超时 fd.fd_array(0) = m_hSocket fd.fd_count = 1 Else If lngRet = 1 Then '成功 CheckStatus = True Else '出错 If lngRet = WSAECONNABORTED Then RaiseEvent OnError(-2, "对方已断开连接") ElseIf lngRet = WSAEWOULDBLOCK Then RaiseEvent OnError(-3, "网络忙") Else RaiseEvent OnError(-100, "其它网络错误") End If End If Exit Do End If If m_blnCancel Then Exit Function DoEvents '转让控制权 Loop Until GetTickCount - lngStartTime > lngSecond * 1000& If lngRet = 0 Then '超时 RaiseEvent OnError(-3, "网络忙") End IfEnd Function