?? csocket.cls
字號:
'
'A value of SOCKET_ERROR means that the socket was not created.
'In this case the SocketExists function must return False
Exit Function '>---> Bottom
'
Else 'NOT M_LNGSOCKETHANDLE...
'
'Get default size of the Winsock's buffers.
Call GetWinsockBuffers 'Modified: 10-MAR-2002
'
End If
'
End If
'
'The m_lngSocketHandle variable contains a valid socket
'handle value. In this case the function returns True.
SocketExists = True
'
End Function
Private Sub GetWinsockBuffers()
'
'This subroutine is to retrieve default size of the Winsock buffers.
'These values will be stored in the module level variables:
'm_lngSendBufferLen and m_lngRecvBufferLen.
'It can be called from the SocketExists and Accept functions.
'
'Added: 10-MAR-2002
'
Dim lngRetValue As Long 'value returned by the getsockopt Winsock API function
Dim lngBuffer As Long 'buffer to pass with the getsockopt call
'
If mvarProtocol = sckTCPProtocol Then
'Buffer for incoming data
lngRetValue = getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_RCVBUF, lngBuffer, 4&)
m_lngRecvBufferLen = lngBuffer
'Buffer for outgoing data
lngRetValue = getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_SNDBUF, lngBuffer, 4&)
m_lngSendBufferLen = lngBuffer
Else 'NOT MVARPROTOCOL...
'the m_lngMaxMsgSize value is returned by InitWinsockService
'function from the MSocketSupport module
m_lngSendBufferLen = m_lngMaxMsgSize
m_lngRecvBufferLen = m_lngMaxMsgSize
End If
'
End Sub
Private Function RecvDataToBuffer() As Long
'
'This function is to retrieve data from the Winsock buffer
'into the class local buffer. The function returns number
'of bytes retrieved (received).
'
Dim lngBytesReceived As Long 'value returned by recv/recvfrom Winsock API function
Dim lngRetValue As Long 'value returned by gethostbyaddr Winsock API function
Dim strTempBuffer As String 'just a temporary buffer
Dim arrBuffer() As Byte 'buffer to pass to the recv/recvfrom Winsock API function
Dim udtSockAddr As sockaddr_in 'socket address of the remote peer
Dim lngSockAddrLen As Long 'size of the sockaddr_in structure
Dim udtHostEnt As HostEnt 'used to get host name with gethostbyaddr function
'
'Prepare the buffer to pass it to the recv/recvfrom Winsock API function.
'The m_lngRecvBufferLen variable was initialized during creating
'of the socket, see the vbSocket function to find out how.
ReDim arrBuffer(m_lngRecvBufferLen - 1)
'
If mvarProtocol = sckTCPProtocol Then
'
'If the socket is a connection-oriented one, just call the recv function
'to retrieve all the arrived data from the Winsock buffer.
lngBytesReceived = recv(m_lngSocketHandle, arrBuffer(0), m_lngRecvBufferLen, 0&)
'
Else 'NOT MVARPROTOCOL...
'
'If the socket uses UDP, it's another story. As stated in the MS Winsock Control
'documentation after receiving data the RemoteHost, RemoteHostIP, and RemotePort
'properties contains parameters of the machine sending the UDP data. To achive
'such a behavior we must use the recvfrom Winsock API function.
'
lngSockAddrLen = Len(udtSockAddr)
'
lngBytesReceived = recvfrom(m_lngSocketHandle, arrBuffer(0), m_lngRecvBufferLen, _
0&, udtSockAddr, lngSockAddrLen)
'
If Not lngBytesReceived = SOCKET_ERROR Then
'
'Now the udtSockAddr contains a socket address of the remote host.
'Initialize the RemoteHost, RemoteHostIP, and RemotePort properties.
'
With udtSockAddr
'
'RemotePort property
m_lngRemotePort = IntegerToUnsigned(ntohs(.sin_port))
'RemoteHostIP property
m_strRemoteHostIP = StringFromPointer(inet_ntoa(.sin_addr))
'RemoteHost property
lngRetValue = gethostbyaddr(.sin_addr, 4&, AF_INET)
CopyMemory udtHostEnt, ByVal lngRetValue, Len(udtHostEnt)
m_strRemoteHost = StringFromPointer(udtHostEnt.hName)
'
End With 'UDTSOCKADDR
'
End If
'
End If
'
If lngBytesReceived > 0 Then
'
'Convert a byte array into the VB string
strTempBuffer = StrConv(arrBuffer(), vbUnicode)
'Store received data in the local buffer for incoming data - m_strRecvBuffer
m_strRecvBuffer = m_strRecvBuffer & Left$(strTempBuffer, lngBytesReceived)
'Return number of received bytes.
RecvDataToBuffer = lngBytesReceived
'
ElseIf lngBytesReceived = SOCKET_ERROR Then 'NOT LNGBYTESRECEIVED...
'
Err.Raise Err.LastDllError, "CSocket.RecvToBuffer", GetErrorDescription(Err.LastDllError)
'
End If
'
End Function
Private Function RecvData(varData As Variant, blnPeek As Boolean, Optional varType As Variant, Optional maxLen As Variant) As Long
'
'This function is to retrieve data from the local buffer (m_strRecvBuffer).
'It can be called by two public methods of the class - GetData and PeekData.
'Behavior of the function is defined by the blnPeek argument. If a value of
'that argument is True, the function returns number of bytes in the
'local buffer, and copy data from that buffer into the varData argument.
'If a value of the blnPeek is False, then this function returns number of
'bytes received, and move data from the local buffer into the varData
'argument. MOVE means that data will be removed from the local buffer.
'
Dim strRecvData As String 'temporary string buffer
Dim arrBuffer() As Byte 'temporary byte array buffer
'
'If the local buffer is empty, go away - we have nothing to do here.
If Len(m_strRecvBuffer) = 0 Then Exit Function ':(燛xpand Structure or consider reversing Condition
'
If IsEmpty(maxLen) Then
maxLen = 0
End If
'
If (Not maxLen > Len(m_strRecvBuffer)) And (maxLen > 0) Then
'
strRecvData = Left$(m_strRecvBuffer, CLng(maxLen))
'
If Not blnPeek Then
m_strRecvBuffer = Mid$(m_strRecvBuffer, CLng(maxLen + 1))
End If
'
arrBuffer() = StrConv(strRecvData, vbFromUnicode)
'
Else 'NOT (NOT...
'
arrBuffer() = StrConv(m_strRecvBuffer, vbFromUnicode)
'
If Not blnPeek Then
m_strRecvBuffer = ""
End If
'
End If
'
If IsEmpty(varType) Then
varData = CStr(StrConv(arrBuffer(), vbUnicode))
Else 'ISEMPTY(VARTYPE) = FALSE
'
Select Case varType
Case vbArray + vbByte
'Modified 28-MAY-2002. Thanks to Michael Freidgeim
'--------------------------------
'Dim strArray As String
'strArray = StrConv(arrBuffer(), vbUnicode)
'varData = StrConv(strArray, vbFromUnicode)
varData = arrBuffer()
'--------------------------------
Case vbBoolean
Dim blnData As Boolean ':(燤ove line to top of current Function
CopyMemory blnData, arrBuffer(0), LenB(blnData)
varData = blnData
Case vbByte
Dim bytData As Byte ':(燤ove line to top of current Function
CopyMemory bytData, arrBuffer(0), LenB(bytData)
varData = bytData
Case vbCurrency
Dim curData As Currency ':(燤ove line to top of current Function
CopyMemory curData, arrBuffer(0), LenB(curData)
varData = curData
Case vbDate
Dim datData As Date ':(燤ove line to top of current Function
CopyMemory datData, arrBuffer(0), LenB(datData)
varData = datData
Case vbDouble
Dim dblData As Double ':(燤ove line to top of current Function
CopyMemory dblData, arrBuffer(0), LenB(dblData)
varData = dblData
Case vbInteger
Dim intData As Integer ':(燤ove line to top of current Function
CopyMemory intData, arrBuffer(0), LenB(intData)
varData = intData
Case vbLong
Dim lngData As Long ':(燤ove line to top of current Function
CopyMemory lngData, arrBuffer(0), LenB(lngData)
varData = lngData
Case vbSingle
Dim sngData As Single ':(燤ove line to top of current Function
CopyMemory sngData, arrBuffer(0), LenB(sngData)
varData = sngData
Case vbString
Dim strData As String ':(燤ove line to top of current Function
strData = StrConv(arrBuffer(), vbUnicode)
varData = strData
'
End Select
'
End If
'
'Added 28-MAY-2002. Thanks to Michael Freidgeim
m_lngBytesReceived = Len(m_strRecvBuffer) 'reset BytesReceived after Getdata
'
End Function
Private Sub DestroySocket()
'
'The purpose of this subroutine is to unregister the socket with
'UnregisterSocket that can be found in the MSocketSupport module
'and close the socket with the closesocket Winsock API function.
'
Dim lngRetValue As Long 'value returned by the closesocket
'Winsock AP function
'
If Not m_lngSocketHandle = INVALID_SOCKET Then
'
'Unregister the socket. For more info on how it works
'see the code of the function in the MSocketSupport module
Call MSocketSupport.UnregisterSocket(m_lngSocketHandle)
'
'Close the socket with the closesocket Winsock API function.
lngRetValue = api_closesocket(m_lngSocketHandle)
'
'
If lngRetValue = SOCKET_ERROR Then
Err.Raise Err.LastDllError, "CSocket.DestroySocket", GetErrorDescription(Err.LastDllError)
End If
'
'Change the SocketHandle property value
m_lngSocketHandle = INVALID_SOCKET
'
'If the bind Winsock API function has been called on
'this socket, m_blnSocketIsBound = True. We need to
'change this value.
m_blnSocketIsBound = False 'Added: 10-MAR-2002
'
End If
'
End Sub
Private Sub Class_Terminate()
'
If Not m_lngSocketHandle = INVALID_SOCKET Then
Call DestroySocket
End If
'
Call CleanupWinsock
'
End Sub
Private Sub SendBufferedData()
'
'This procedure sends data from the local buffer (m_strSendBuffer).
'The data from the client application is passed with the SendData
'method of the class as an argument and is stored in the local
'buffer until all the data from that buffer will be sent using this
'subroutine.
'
'Why do we need to store data in the local buffer? There are some
'things happenning in the Winsock's buffer for outgoing data since
'we're using non-blocking sockets' calls. If that buffer is full,
'the transport subsystem doesn't take the data and the send/sendto
'functions return a value of SOCKET_ERROR, Err.LastDllError give
'us a value of WSAEWOULDBLOCK. This means that if the socket would
'be a blocking one, such a call would block socket until the buffer
'will be freed and ready to accept some data to send.
'
'So this procedure can be called several (mostly not more than two)
'times for the same chunk of data. First call is in the body of the
'SendData method, and other calls (if necessary) will be performed
'from the PostSocketEvent subroutine, as soon as the FD_WRITE message
'will be received. The arrival of the FD_WRITE message means that a
'socket is in a write-able state - its buffer is ready to get data.
'
Dim lngRetValue As Long 'value returned by send/sendto Winsock API function
Dim arrData() As Byte 'data to send with the send/sendto function
Dim lngBufferLength As Long 'size of the data buffer to send
Dim udtSockAddr As sockaddr_in 'address of the remote socket - for the sendto function
'
'The send/sendto function needs this value for one of its arguments
lngBufferLength = Len(m_strSendBuffer)
'
'Convert data from a VB string to a byte array
arrData() = StrConv(m_strSendBuffer, vbFromUnicode)
'
If mvarProtocol = sckTCPProtocol Then
'
'just call the send function in order to send data via connection
lngRetValue = send(m_lngSocketHandle, arrData(0), lngBufferLength, 0&)
'
Else 'NOT MVARPROTOCOL...
'
'With UDP socket we are going to use the sendto Winsock API function.
'This function needs the socket address of the remote host to send
'message to.
'
If Len(m_strRemoteHostIP) = 0 Then
'
'If the RemoteHostIP property is empty, we don't know
'the remote IP so we need to resolve that address.
'
m_varInternalState = istSendingDatagram
m_lngRequestID = MSocketSupport.ResolveHost(m_strRemoteHost, ObjPtr(Me))
'
'The ResolveHost is an asynchronous call. This subroutine wiil be called
'one more time from the PostGetHostEvent procedure when the host will be
'resolved.
'
Else 'NOT LEN(M_STRREMOTEHOSTIP)...
'
'If we are here the host was resolved successfully and the RemoteHostIP
'property provides us with IP to send a UDP message to.
'
'Build the sockaddr_in structure to pass the remote socket address
'to the sendto function.
With udtSockAddr
.sin_addr = inet_addr(m_strRemoteHostIP)
.sin_port = htons(UnsignedToInteger(m_lngRemotePort))
.sin_family = AF_INET
End With 'UDTSOCKADDR
'
'Call the sendto function in order to send a UDP message
lngRetValue = sendto(m_lngSocketHandle, arrData(0), lngBufferLength, 0&, udtSockAddr, Len(udtSockAddr))
'
End If
'
End If
'
If lngRetValue = SOCKET_ERROR Then
'
'If a value of Err.LastDllError is WSAEWOULDBLOCK, that means
'that the Winsock's buffer for outgoing data is full and cannot
'accept data to send. In this case we ignore this error and do
'not empty local buffer (m_strSendBuffer).
'
If Not Err.LastDllError = WSAEWOULDBLOCK Then
Err.Raise Err.LastDllError, "CSocket.SendData", GetErrorDescription(Err.LastDllError)
End If
'
Else 'NOT LNGRETVALUE...
'
'The data were sent successfully. Raise the OnSendProgress or
'OnSendComplete event to let the client app know.
'
'
If Len(m_strSendBuffer) > lngRetValue Then
'
m_strSendBuffer = Mid$(m_strSendBuffer, lngRetValue + 1)
'
Else 'NOT LEN(M_STRSENDBUFFER)...
m_strSendBuffer = ""
RaiseEvent OnSendComplete
End If
'
RaiseEvent OnSendProgress(lngRetValue, Len(m_strSendBuffer))
'
End If
'
End Sub
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -