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 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_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 RecvBufferSize() As Long
If m_hSocket <> INVALID_SOCKET Then RecvBufferSize = RECV_BUFFER_SIZE
End Property
Public 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_SIZE
End Property
Public 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 Property
Public Property Get RecvTimeout() As Long
If m_hSocket <> INVALID_SOCKET Then RecvTimeout = RECV_TIMEOUT
End Property
Public 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 Property
Public Property Get SendTimeout() As Long
If m_hSocket <> INVALID_SOCKET Then SendTimeout = SEND_TIMEOUT
End Property
Public 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 = False
End 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 If
End 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 = 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
'----------------------------------------------------
' 函數功能：輔助函數，檢查套接字指定的狀態是否準備就緒
' 參數說明：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 If
End Function
Visual Basic Winsock API操作模塊(基於API方式的socket同步阻塞通訊類)
發表評論
所有評論
還沒有人評論，想成為第一個評論的人麼? 請在上方評論欄輸入並且點擊發布.
相關文章
windows開機自啓動bat文件
步驟： 1、win+R，打開運行，輸入“shell:startup”，打開Windows啓動文件夾 2、將.bat快捷文件粘貼到Windows啓動文件夾中 3、重啓電腦後，系統自啓動.bat文件