| Pubblicazione File: CSocket Documento generato mediante: Documentation Creator By BGSoftware |
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "CSocket"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' *********************************************************************
'* CLASS Classe rappresentante una socket TCPIP per Visual Basic
'* <BR/>Autore: Copyright © 2002 by <B>Oleg Gdalevich</B>
'* Data : Settembre 2004
'* <DIV CLASS="ClassDescription">
'* To use this class module you need:' MSocketSupport code module
'* Version: 1.0.12 Modified: 17-OCT-2002
'* To get latest version of this code please visit the following web page:
'* http://www.vbip.com/winsock-api/csocket-class/csocket-class-01.asp
'* <BR/>Classe adattata da Giorgio Bernardi
'* <B>Importante:</B> le socket vanno chiuse esplicitamente altrimenti il GarbageCollector di _
Visual Basic le lascia aperte indefinitamente causando spiacevoli errori ed inconvenienti!
'* </DIV>
' *********************************************************************
Option Explicit
'* Tipi di Socket ammissibili
Public Enum enmSocketType
SOCK_STREAM = 1 ' /* stream socket */
SOCK_DGRAM = 2 ' /* datagram socket */
SOCK_RAW = 3 ' /* raw-protocol interface */
SOCK_RDM = 4 ' /* reliably-delivered message */
SOCK_SEQPACKET = 5 ' /* sequenced packet stream */
End Enum
'* Opzioni per le socket
Public Enum enmSocketOptions
SO_DEBUG = &H1& ' Turn on debugging info recording
SO_ACCEPTCONN = &H2& ' Socket has had listen() - READ-ONLY.
SO_REUSEADDR = &H4& ' Allow local address reuse.
SO_KEEPALIVE = &H8& ' Keep connections alive.
SO_DONTROUTE = &H10& ' Just use interface addresses.
SO_BROADCAST = &H20& ' Permit sending of broadcast msgs.
SO_USELOOPBACK = &H40& ' Bypass hardware when possible.
SO_LINGER = &H80& ' Linger on close if data present.
SO_OOBINLINE = &H100& ' Leave received OOB data in line.
SO_DONTLINGER = Not SO_LINGER
SO_EXCLUSIVEADDRUSE = Not SO_REUSEADDR ' Disallow local address reuse.
' Additional options.
SO_SNDBUF = &H1001& ' Send buffer size.
SO_RCVBUF = &H1002& ' Receive buffer size.
SO_ERROR = &H1007& ' Get error status and clear.
SO_TYPE = &H1008& ' Get socket type - READ-ONLY.
End Enum
'* Enumerazione di tutte le famiglie di indirizzi ammesse per le Socket.
'* Although AF_UNSPEC is defined for backwards compatibility, using _
AF_UNSPEC for the "af" parameter when creating a socket is STRONGLY _
DISCOURAGED. The interpretation of the "protocol" parameter _
depends on the actual address family chosen. As environments grow _
to include more and more address families that use overlapping _
protocol values there is more and more chance of choosing an _
undesired address family when AF_UNSPEC is used.
Public Enum enmAddressFamily
AF_UNSPEC = 0 '/* unspecified */
AF_UNIX = 1 '/* local to host (pipes, portals) */
AF_INET = 2 '/* internetwork: UDP, TCP, etc. */
AF_IMPLINK = 3 '/* arpanet imp addresses */
AF_PUP = 4 '/* pup protocols: e.g. BSP */
AF_CHAOS = 5 '/* mit CHAOS protocols */
AF_NS = 6 '/* XEROX NS protocols */
AF_IPX = AF_NS '/* IPX protocols: IPX, SPX, etc. */
AF_ISO = 7 '/* ISO protocols */
AF_OSI = AF_ISO '/* OSI is ISO */
AF_ECMA = 8 '/* european computer manufacturers */
AF_DATAKIT = 9 '/* datakit protocols */
AF_CCITT = 10 '/* CCITT protocols, X.25 etc */
AF_SNA = 11 '/* IBM SNA */
AF_DECnet = 12 '/* DECnet */
AF_DLI = 13 '/* Direct data link interface */
AF_LAT = 14 '/* LAT */
AF_HYLINK = 15 '/* NSC Hyperchannel */
AF_APPLETALK = 16 '/* AppleTalk */
AF_NETBIOS = 17 '/* NetBios-style addresses */
AF_VOICEVIEW = 18 '/* VoiceView */
AF_FIREFOX = 19 '/* Protocols from Firefox */
AF_UNKNOWN1 = 20 '/* Somebody is using this! */
AF_BAN = 21 '/* Banyan */
AF_ATM = 22 '/* Native ATM Services */
AF_INET6 = 23 '/* Internetwork Version 6 */
AF_CLUSTER = 24 '/* Microsoft Wolfpack */
AF_12844 = 25 '/* IEEE 1284.4 WG AF */
AF_MAX = 26
End Enum
'* Protocoli ammissibili per le Socket
Public Enum enmSocketProtocol
IPPROTO_IP = 0 '/* dummy for IP */
IPPROTO_ICMP = 1 '/* control message protocol */
IPPROTO_IGMP = 2 '/* internet group management protocol */
IPPROTO_GGP = 3 '/* gateway^2 (deprecated) */
IPPROTO_TCP = 6 '/* tcp */
IPPROTO_PUP = 12 '/* pup */
IPPROTO_UDP = 17 '/* user datagram protocol */
IPPROTO_IDP = 22 '/* xns idp */
IPPROTO_ND = 77 '/* UNOFFICIAL net disk proto */
IPPROTO_RAW = 255 '/* raw IP packet */
IPPROTO_MAX = 256
End Enum
'The CSocket error's constants as for
'the MS Winsock Control interface
Public Enum ErrorConstants
sckAddressInUse = 10048
sckAddressNotAvailable = 10049
sckAlreadyComplete = 10037
sckAlreadyConnected = 10056
sckBadState = 40006
sckConnectAborted = 10053
sckConnectionRefused = 10061
sckConnectionReset = 10054
sckGetNotSupported = 394
sckHostNotFound = 11001
sckHostNotFoundTryAgain = 11002
sckInProgress = 10036
sckInvalidArg = 40014
sckInvalidArgument = 10014
sckInvalidOp = 40020
sckInvalidPropertyValue = 380
sckMsgTooBig = 10040
sckNetReset = 10052
sckNetworkSubsystemFailed = 10050
sckNetworkUnreachable = 10051
sckNoBufferSpace = 10055
sckNoData = 11004
sckNonRecoverableError = 11003
sckNotConnected = 10057
sckNotInitialized = 10093
sckNotSocket = 10038
sckOpCanceled = 10004
sckOutOfMemory = 7
sckOutOfRange = 40021
sckPortNotSupported = 10043
sckSetNotSupported = 383
sckSocketShutdown = 10058
sckSuccess = 40017
sckTimedout = 10060
sckUnsupported = 40018
sckWouldBlock = 10035
sckWrongProtocol = 40026
End Enum
'* The CSocket state's constants as for the MS Winsock Control interface
Public Enum StateConstants
sckClosed = 0
sckOpen = 1
sckListening = 2
sckConnectionPending = 3
sckResolvingHost = 4
sckHostResolved = 5
sckConnecting = 6
sckConnected = 7
sckClosing = 8
sckError = 9
End Enum
'* The CSocket protocol's constants as for the MS Winsock Control interface
Public Enum ProtocolConstants
sckTCPProtocol = 0
sckUDPProtocol = 1
End Enum
'* In order to resolve a host name the MSocketSupport.ResolveHost _
function can be called from the Connect and SendData methods _
of this class. The callback acceptor for that routine is the _
PostGetHostEvent procedure. This procedure determines what to _
do next with the received host's address checking a value of _
the m_varInternalState variable.
Private Enum InternalStateConstants
istConnecting
istSendingDatagram
End Enum
'* Stato interno della connessione
Private m_varInternalState As InternalStateConstants
'* Local (module level) variables to hold values of the properties of this (CSocket) class.
Private mvarProtocol As ProtocolConstants
'* Local (module level) variables to hold values of the properties of this (CSocket) class.
Private mvarState As StateConstants
'* Local (module level) variables to hold values of the properties of this (CSocket) class.
Private m_lngBytesReceived As Long
'* Resolving host names is performed in an asynchronous mode, _
the m_lngRequestID variable just holds the value returned _
by the ResolveHost function from the MSocketSupport module.
Private m_lngRequestID As Long
'* Internal (for this class) buffers. They are the VB Strings.
'* Don't trust that guy who told that the VB String data type _
cannot properly deal with binary data. Actually, it can, and _
moreover you have a lot of means to deal with that data - _
the VB string functions (such as Left, Mid, InStr and so on).
'*If you need to get a byte array from a string, just call the _
StrConv function:
'* byteArray() = StrConv(strBuffer, vbFromUnicode)
'* <BR/>The internal buffer for outgoing data
Private mstrSendBuffer As String
'* Internal (for this class) buffers. They are the VB Strings.
'* Don't trust that guy who told that the VB String data type _
cannot properly deal with binary data. Actually, it can, and _
moreover you have a lot of means to deal with that data - _
the VB string functions (such as Left, Mid, InStr and so on).
'*If you need to get a byte array from a string, just call the _
StrConv function:
'* byteArray() = StrConv(strBuffer, vbFromUnicode)
'* <BR/>The internal buffer for outgoing data
Private mstrRecvBuffer As String
'* Lenght of the Winsock buffers. By default = 8192 bytes for TCP sockets.
'* These values are initialized in the SocketExists function.
'* Now, I really don't know why I was in need to get these values.
Private mlngSendBufferLen As Long
'* Lenght of the Winsock buffers. By default = 8192 bytes for TCP sockets.
'* These values are initialized in the SocketExists function.
'* Now, I really don't know why I was in need to get these values.
Private mlngRecvBufferLen As Long
'* Maximum size of a datagram that can be sent through _
a message-oriented (UDP) socket. This value is returned _
by the InitWinsock function from the MSocketSupport module.
Private mlngMaxMsgSize As Long
'* This flag variable indicates that the socket is bound to _
some local socket address
Private mblnSocketIsBound As Boolean 'Added: 10-MAR-2002
Private mblnSendFlag As Boolean 'Added: 12-SEP-2002
'* This flag variable indicates that the SO_BROADCAST option
'* is set on the socket
Private mblnBroadcast As Boolean 'Added: 09-JULY-2002
'* These are those MS Winsock's events.
'* Pay attention that the "On" prefix is added.
Public Event OnClose()
Attribute OnClose.VB_Description = "Occurs when the connection has been closed"
'* These are those MS Winsock's events.
'* Pay attention that the "On" prefix is added.
Public Event OnConnect()
Attribute OnConnect.VB_Description = "Occurs connect operation is completed"
'* These are those MS Winsock's events.
'* Pay attention that the "On" prefix is added.
Public Event OnConnectionRequest(ByVal requestID As Long)
'* These are those MS Winsock's events.
'* Pay attention that the "On" prefix is added.
Public Event OnDataArrival(ByVal bytesTotal As Long)
'* These are those MS Winsock's events.
'* Pay attention that the "On" prefix is added.
Public Event OnError(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)
'* These are those MS Winsock's events.
'* Pay attention that the "On" prefix is added.
Public Event OnSendComplete()
'* These are those MS Winsock's events.
'* Pay attention that the "On" prefix is added.
Public Event OnSendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long)
'* Identificativo del sistema per la socket aperta. Vale 0 se è chiusa
Private mlngSocketID As Long
'* Indirizzo locale della socket
Private WithEvents mLocalHost As CRemoteHost
Attribute mLocalHost.VB_VarHelpID = -1
'* Indirizzo remoto della socket
Private WithEvents mRemoteHost As CRemoteHost
Attribute mRemoteHost.VB_VarHelpID = -1
'* Variabile contenente gli ultimi dati arrivati sulla Socket
'* Famiglia di indirizzi della socket creata
Private AddressFamily As enmAddressFamily
'* Famiglia di indirizzi della socket creata
Private SocketType As enmSocketType
'* Ultimi dati ricevuti ma non ancora recuperati dall'utente
'* Lunghezza ultimi dati ricevuti ma non ancora recuperati dall'utente
Private mstrLastError As String
Private mlngLastErrorCode As Long
'* Utile per non generare eccezioni ma usare le funzioni gestendo eventuali risultati non validi
Public CatchErrors As Boolean
Private mProtocollo As enmSocketProtocol
'* Procedura duplicata in OpenFromRequestID per compatibilita con MsWinSock control
Public Function Accept(requestID As Long) As Boolean
Attribute Accept.VB_Description = "Accept an incoming connection request"
Accept = OpenFromReqID(requestID)
End Function
'* Metodo da chiamare per le socket di tipo Server in stato Listening.
Public Function AcceptNextConnection(requestID As Long) As CSocket
Dim newSocket As CSocket
'Creo la nuova socket
Set newSocket = New CSocket
Call newSocket.OpenFromReqID(requestID)
Set AcceptNextConnection = newSocket
End Function
'* Consente di creare una Socket lato Client verso l'indirizzo specificato
'* Vengono in pratica effettuate le seguenti operazioni:
'* <OL> _
<LI>Create()</LI> _
<LI>Bind()</LI> _
<LI>Connect()</LI> _
</OL>
'* Tenta di Collegare la socket creata ad un numero di porta nell'Host locale.
'* Se non vengono passati i parametri necessari (Porta e LocalIP) vengono usati quelli precedentemente settati.
'* Per creare una connessione locale senza specificare una porta, lasciare 0 come porta locale.
Public Function Bind(Optional LocalHostDescription As CRemoteHost = Nothing, Optional ReusePort As Boolean = True) As Boolean
Dim saLocalAddr As SOCK_ADDR
Dim WSAResult As Long
If Not IsCreated() Then If Not Create() Then Exit Function
If Not LocalHostDescription Is Nothing Then Set LocalHost = LocalHostDescription
'Bind socket to LocalHostIP
saLocalAddr.sin_family = AddressFamily
saLocalAddr.sin_port = LocalHost.PortToNetworkSpecs
saLocalAddr.sin_addr.S_addr = LocalHost.IP.AsInetAddress()
If (saLocalAddr.sin_addr.S_addr = INADDR_NONE) Then
Call GenerateError(GetLastErrorCode("Error in Bind::inet_addr"))
Exit Function
End If
'//Setto l'opzione per il riutilizzo della porta se necessario
If (ReusePort = True) Then _
Call setsockopt(SocketID, SOL_SOCKET, SO_REUSEADDR, 1&, 4&)
WSAResult = sBind(SocketID, saLocalAddr, Len(saLocalAddr))
If (WSAResult <> SOCKET_ERROR) Then
Bind = True
mblnSocketIsBound = True
Else
Call GenerateError(GetLastErrorCode("Error in Bind"))
End If
End Function
'* Numero di bytes ricevuti e pronti per essere recuperati
Public Property Get BytesReceived() As Long
Attribute BytesReceived.VB_Description = "Returns the number of bytes received on this connection"
BytesReceived = m_lngBytesReceived
End Property
'* Permette di chiudere la socket
Public Sub CloseSocket()
Attribute CloseSocket.VB_Description = "Close current connection"
On Error GoTo Close_Err_Handler
'
'Why do we need to run the code that should not be running?
If SocketID = INVALID_SOCKET Then Exit Sub
'
If Not mvarState = sckConnected Then
'
'If the socket is not connected we can just close it
Call DestroySocket
mvarState = sckClosed
'Debug.Print "mvarState = sckClosed"
'
Else
'
'If the socket is connected, it's another story.
'In order to be sure that no data will be lost the
'graceful shutdown of the socket should be performed.
'
mvarState = sckClosing
'Debug.Print "mvarState = sckClosing"
'
'Call the shutdown Winsock API function in order to
'close the connection. That doesn't mean that the
'connection will be closed after the call of the
'shutdown function. Connection will be closed from
'the PostSocketEvent subroutine when the FD_CLOSE
'message will be received.
'
'For people who know what the FIN segment in the
'TCP header is - this function sends an empty packet
'with the FIN bit turned on.
'
If shutdown(SocketID, SD_SEND) = SOCKET_ERROR Then
Call GenerateError(GetErrorDescription(Err.LastDllError))
End If
End If
EXIT_LABEL:
Exit Sub
Close_Err_Handler: Call GenerateErrorGenerico("CloseSocket")
End Sub
'* Consente di collegare la socket creata all'host remoto.
'* La socket deve essere già stata collegata all'host locale attraverso la Bind()
'* Se non viene specificato l'host remoto verranno usate le informazioni già settate.
Public Function Connect(Optional RemoteHostDescription As CRemoteHost = Nothing) As Boolean
Dim saRemoteAddr As SOCK_ADDR
Dim WSAResult As Long
If Not IsCreated() Then If Not Create() Then Exit Function
If Not RemoteHostDescription Is Nothing Then Set RemoteHost = RemoteHostDescription
m_varInternalState = istConnecting
'Connect with remote host
saRemoteAddr.sin_family = AddressFamily
saRemoteAddr.sin_port = RemoteHost.PortToNetworkSpecs
saRemoteAddr.sin_addr.S_addr = RemoteHost.IP.AsInetAddress()
If (saRemoteAddr.sin_addr.S_addr = INADDR_NONE) Then
Call GenerateError(GetLastErrorCode("Error in Connect::inet_addr=INADDR_NONE"))
Exit Function
End If
'saRemoteAddr.sin_zero(0) = 0
WSAResult = sConnect(SocketID, saRemoteAddr, Len(saRemoteAddr))
Connect = True
If (WSAResult <> SOCKET_ERROR) Then
Else
'
'The WSAEWOULDBLOCK error is OK for such a socket
'
If Not Err.LastDllError = WSAEWOULDBLOCK Then
Call GenerateError("Error in Connect")
Else
'Change the State property value
mvarState = sckConnecting
'Debug.Print "mvarState = sckConnecting"
End If
End If
End Function
'* Tenta di creare l'oggetto Socket a basso livello.
'* Viene creata una socket di tipo dediderato.
Public Function Create(Optional ByVal af As enmAddressFamily = AF_INET, Optional ByVal st As enmSocketType = SOCK_STREAM) As Boolean
AddressFamily = af
SocketType = st
If SocketType = SOCK_STREAM Then
mvarProtocol = sckTCPProtocol
mProtocollo = IPPROTO_TCP
Else
mvarProtocol = sckUDPProtocol
mProtocollo = IPPROTO_UDP
End If
SocketID = sSocket(af, st, mProtocollo)
If (SocketID = INVALID_SOCKET) Then
GenerateError GetLastErrorCode("Errore in API Socket()")
Else
If RegisterSocket(SocketID, ObjPtr(Me)) Then
'Get default size of the Winsock's buffers.
Call GetWinsockBuffers 'Modified: 10-MAR-2002
Create = True
Else
Call sCloseSocket(SocketID)
SocketID = INVALID_SOCKET
GenerateError GetLastErrorCode("Errore in API RegisterSocket()")
End If
End If
End Function
'* Recupera i dati dal buffer eliminandoli
Public Function GetData(varData As Variant, Optional VarType As Variant, Optional maxLen As Variant) As Boolean
Attribute GetData.VB_Description = "Retrieve data sent by the remote computer"
'
Dim lngBytesReceived As Long 'value returned by the RecvData function
'
On Error GoTo GetData_Err_Handler
'
'A value of the second argument of the RecvData subroutine is False, so in this way
'this procedure will retrieve incoming data from the buffer.
lngBytesReceived = RecvData(varData, False, IIf(IsMissing(VarType), Empty, VarType), _
IIf(IsMissing(maxLen), Empty, maxLen))
GetData = (lngBytesReceived > 0)
EXIT_LABEL:
'
Exit Function
'
GetData_Err_Handler:
'
Err.Raise Err.Number, "CSocket.GetData", Err.Description
'
GoTo EXIT_LABEL
'
End Function
'* Indica se la socket è attualmente creata
Public Property Get IsBound() As Boolean
IsBound = mblnSocketIsBound
End Property
'* Indica se la socket è attualmente creata
Public Property Get IsCreated() As Boolean
IsCreated = (SocketID <> INVALID_SOCKET)
End Property
'* Indica se ci sono attualmente dati utili in ingresso
Public Function IsDataAvailable() As Boolean
IsDataAvailable = (Len(mstrRecvBuffer) > 0)
End Function
'* Indica se la socket è attualmente aperta
Public Property Get IsOpen() As Boolean
IsOpen = (mvarState <> sckClosed)
End Property
'* Descrizione dell'ultimo errore
Public Property Get LastError() As String
LastError = mstrLastError
End Property
'* Numero dell'ultimo errore
Public Property Get LastErrorCode() As Long
LastErrorCode = mlngLastErrorCode
End Property
'* Consente di mettere in ascolto la socket creata.
'* La socket deve essere già stata collegata all'host locale attraverso la Bind()
Public Function Listen() As Boolean
Dim WSAResult As Long
If Not IsCreated() Then If Not Create() Then Exit Function
If Not IsBound() Then If Not Bind() Then Exit Function
'Mi metto in ascolto sulla porta precedentemente collegata alla socket
WSAResult = api_listen(SocketID, 5&)
'Gestione errore
If WSAResult <> SOCKET_ERROR Then
Listen = True
mvarState = sckListening
Else
Call GenerateError(GetLastErrorCode("Error in Listen"))
End If
End Function
'* Questa funzione consente di creare una socket avendo a disposizione l'Handle di richiesta _
ottenuto da una CSoket di tipo Server.
'* Indirizzo locale della socket
Public Property Get LocalHost() As CRemoteHost
Set LocalHost = mLocalHost
End Property
Public Function OpenClientTCPConnection(Optional ResetLocalPort As Boolean = True) As Boolean
OpenClientTCPConnection = False
'Se è aperta una socket la chiudo
If IsOpen Then Call CloseSocket
If ResetLocalPort Then LocalHost.Port = 0 'In questo modo sceglie il pc quale porta usare.
'Creo la socket
If Not Create(AF_INET, SOCK_STREAM) Then Exit Function
'La collego all'host locale
If Not Bind() Then Exit Function
'La connetto all'host remoto
OpenClientTCPConnection = Connect()
End Function
'* Consente di creare una Socket lato Client di tipo DataGram UDP
'* Vengono in pratica effettuate le seguenti operazioni:
'* <OL> _
<LI>Create()</LI> _
<LI>Bind()</LI> _
</OL>
Public Function OpenClientUDPConnection() As Boolean
OpenClientUDPConnection = False
'Se è aperta una socket la chiudo
If IsOpen Then Call CloseSocket
'Creo la socket
If Not Create(AF_INET, SOCK_DGRAM) Then Exit Function
'La collego all'host locale - Per le UDP non serve la connessione
OpenClientUDPConnection = Bind()
End Function
'* Consente di creare una Socket server
'* Vengono in pratica effettuate le seguenti operazioni:
'* <OL> _
<LI>Create()</LI> _
<LI>Bind()</LI> _
<LI>Connect()</LI> _
</OL>
Public Function OpenFromReqID(requestID As Long) As Boolean
Dim PeerAddress As SOCK_ADDR 'Usato per recuperare il mio indirizzo e l'indirizzo dell'altro
Dim lngBuffer As enmSocketType
Dim WSAResult As Long
'Identificativo della Socket
SocketID = requestID
'Ottengo le informazioni locali
WSAResult = getsockname(SocketID, PeerAddress, Len(PeerAddress))
If WSAResult = WSANOERROR Then
LocalHost.PortFromNetworkSpecs = PeerAddress.sin_port
LocalHost.IP.FromInetAddress = PeerAddress.sin_addr.S_addr
AddressFamily = PeerAddress.sin_family
End If
'Ottengo le informazioni remote
WSAResult = getpeername(SocketID, PeerAddress, Len(PeerAddress))
If WSAResult = WSANOERROR Then
RemoteHost.PortFromNetworkSpecs = PeerAddress.sin_port
RemoteHost.IP.FromInetAddress = PeerAddress.sin_addr.S_addr
End If
'Ottengo le informazioni di protocollo dalla socket
WSAResult = getsockopt(SocketID, SOL_SOCKET, SO_TYPE, lngBuffer, LenB(lngBuffer))
If WSAResult <> SOCKET_ERROR Then
SocketType = lngBuffer
If SocketType = SOCK_STREAM Then
mvarProtocol = sckTCPProtocol
Else
mvarProtocol = sckUDPProtocol
End If
End If
'Get default size of the Winsock's buffers.
Call GetWinsockBuffers 'Added: 10-MAR-2002
If MSocketSupport.RegisterSocket(SocketID, ObjPtr(Me)) Then
'Change the State property value
mvarState = sckConnected
End If
OpenFromReqID = True
End Function
Public Function OpenServerConnection() As Boolean
OpenServerConnection = False
'Se è aperta una socket la chiudo
If IsOpen Then Call CloseSocket
'Creo la socket
If Not Create() Then Exit Function
'La collego all'host locale
If Not Bind() Then Exit Function
'La connetto all'host remoto
OpenServerConnection = Listen()
End Function
'* Permette di verificare se nel buffer di ricezione sono presenti dati.
Public Sub PeekData(varData As Variant, Optional VarType As Variant, Optional maxLen As Variant)
Attribute PeekData.VB_Description = "Look at incoming data without removing it from the buffer"
'
Dim lngBytesReceived As Long 'value returned by the RecvData function
'
On Error GoTo PeekData_Err_Handler
'
'The RecvData is a universal subroutine that can either to retrieve or peek
'data from the Winsock buffer. If a value of the second argument (blnPeek As Boolean)
'of the RecvData subroutine is True, it will be just peeking.
lngBytesReceived = RecvData(varData, True, IIf(IsMissing(VarType), Empty, VarType), _
IIf(IsMissing(maxLen), Empty, maxLen))
'
EXIT_LABEL:
'
Exit Sub
'
PeekData_Err_Handler:
'
Err.Raise Err.Number, "CSocket.PeekData", Err.Description
'
GoTo EXIT_LABEL
'
End Sub
'* Tipo di protocollo utilizzato in breve
Public Property Get Protocol() As ProtocolConstants
Attribute Protocol.VB_Description = "Returns/Sets the socket protocol"
Protocol = mvarProtocol
End Property
'* Tipo di protocollo utilizzato in breve
Public Property Let Protocol(newValue As ProtocolConstants)
If SocketID = INVALID_SOCKET Then 'Modified: 10-MAR-2002
mvarProtocol = newValue
End If
End Property
'* Indirizzo remoto della socket
Public Property Get RemoteHost() As CRemoteHost
Attribute RemoteHost.VB_Description = "Returns/Sets the name used to identify the remote computer"
Set RemoteHost = mRemoteHost
End Property
Public Function SendData(varData As Variant) As Boolean
'
'data to send - will be built from the varData argument
Dim arrData() As Byte
'this strucure just contains address of the remote socket to send data to;
'only for UDP sockets when the sendto Winsock API function is used
On Error GoTo SendData_Err_Handler
'
'If a connection-oriented (TCP) socket was not created or connected to the
'remote host before calling the SendData method, the MS Winsock Control
'raises the sckBadState error.
If mvarProtocol = sckTCPProtocol Then
If SocketID = INVALID_SOCKET Then
Call GenerateError("Wrong protocol or connection state for the requested transaction or request.")
Exit Function
End If
Else
'If the socket is a message-oriented one (UDP), this is OK to create
'it with the call of the SendData method. The SocketExists function
'creates a new socket.
If Not IsCreated Then If Not Create(, SOCK_DGRAM) Then Exit Function
End If
Select Case VarType(varData)
Case vbArray + vbByte
'Modified 28-MAY-2002. Thanks to Michael Freidgeim
'--------------------------------
'Dim strArray As String
'strArray = CStr(varData)
arrData() = varData
'--------------------------------
Case vbBoolean
Dim blnData As Boolean
blnData = CBool(varData)
ReDim arrData(LenB(blnData) - 1)
CopyMemory arrData(0), blnData, LenB(blnData)
Case vbByte
Dim bytData As Byte
bytData = CByte(varData)
ReDim arrData(LenB(bytData) - 1)
CopyMemory arrData(0), bytData, LenB(bytData)
Case vbCurrency
Dim curData As Currency
curData = CCur(varData)
ReDim arrData(LenB(curData) - 1)
CopyMemory arrData(0), curData, LenB(curData)
Case vbDate
Dim datData As Date
datData = CDate(varData)
ReDim arrData(LenB(datData) - 1)
CopyMemory arrData(0), datData, LenB(datData)
Case vbDouble
Dim dblData As Double
dblData = CDbl(varData)
ReDim arrData(LenB(dblData) - 1)
CopyMemory arrData(0), dblData, LenB(dblData)
Case vbInteger
Dim intData As Integer
intData = CInt(varData)
ReDim arrData(LenB(intData) - 1)
CopyMemory arrData(0), intData, LenB(intData)
Case vbLong
Dim lngData As Long
lngData = CLng(varData)
ReDim arrData(LenB(lngData) - 1)
CopyMemory arrData(0), lngData, LenB(lngData)
Case vbSingle
Dim sngData As Single
sngData = CSng(varData)
ReDim arrData(LenB(sngData) - 1)
CopyMemory arrData(0), sngData, LenB(sngData)
Case vbString
Dim strData As String
strData = CStr(varData)
ReDim arrData(Len(strData) - 1)
arrData() = StrConv(strData, vbFromUnicode)
Case Else
'
'Unknown data type
'
End Select
'
'Store all the data to send in the module level
'variable mstrSendBuffer.
mstrSendBuffer = StrConv(arrData(), vbUnicode)
'
'Call the SendBufferedData subroutine in order to send the data.
'The SendBufferedData sub is just a common procedure that is
'called from different places in this class.
'Nothing special - just the code reuse.
mblnSendFlag = True
SendData = SendBufferedData
EXIT_LABEL:
'
Exit Function
'
SendData_Err_Handler:
'
If Err.LastDllError = WSAENOTSOCK Then
Call GenerateError("Wrong protocol or connection state for the requested transaction or request." & vbCrLf & Err.Description)
Else
Call GenerateErrorGenerico("SendData")
End If
'
GoTo EXIT_LABEL
'
End Function
Public Property Get SocketHandle() As Long
Attribute SocketHandle.VB_Description = " Returns the socket handle"
SocketHandle = SocketID
End Property
'* Contiene l'identificativo univoco attribuito dal sistema alla Socket creata
Public Property Get SocketID() As Long
SocketID = mlngSocketID
End Property
'* Permette di spedire dati attraverso la Socket.
'* Il metodo è sincrono se tutti i dati vengono inviati in un solo invio, altrimenti l'oggetto _
gestisce l'invio multiplo
Public Property Get State() As StateConstants
State = mvarState
End Property
Private Sub Class_Initialize()
Set LocalHost = New CRemoteHost
Set RemoteHost = New CRemoteHost
AddressFamily = AF_INET
'Socket's handle default value
SocketID = INVALID_SOCKET
'Initialize the Winsock service
mlngMaxMsgSize = MSocketSupport.InitWinsockService
CatchErrors = True
End Sub
Private Sub Class_Terminate()
If IsCreated Then Call DestroySocket
Call CleanupWinsock
End Sub
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
'
mstrRecvBuffer = "" 'Added: 17-OCT-2002
'
If Not SocketID = 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(SocketID)
'
'Close the socket with the closesocket Winsock API function.
lngRetValue = sCloseSocket(SocketID)
'
'Debug.Print SocketID & ": closed"
'
If lngRetValue <> SOCKET_ERROR Then
'
'Change the SocketHandle property value
SocketID = INVALID_SOCKET
'
'If the bind Winsock API function has been called on
'this socket, mblnSocketIsBound = True. We need to
'change this value.
mblnSocketIsBound = False 'Added: 10-MAR-2002
'
mblnBroadcast = False 'Added: 09-JULY-2002
'
Else
Call GenerateError(GetErrorDescription(Err.LastDllError))
End If
End If
'
End Sub
'* Gestisce l'errore
Private Sub GenerateError(Description As String, Optional Number As Long = vbObjectError)
LastError = Description
If Number <> vbObjectError Then mlngLastErrorCode = Number
If Not CatchErrors Then Err.Raise LastErrorCode, , Description
End Sub
'* Gestisce l'errore
Private Sub GenerateErrorGenerico(Procedure As String)
Call GenerateError("Errore non previsto in " & Procedure & vbCrLf & Err.Description, Err.Number)
End Sub
Private Function GetLastErrorCode(Optional ByVal strAdditionalInfo As String)
Dim DefaultError As String
mlngLastErrorCode = WSAGetLastError
Select Case mlngLastErrorCode
Case INADDR_NONE
DefaultError = "INNADDR_NONE: The passed-in string does not contain a legitimate Internet address (for example, if a portion of an 'a.b.c.d' address exceeds 255), inet_addr returns the value INADDR_NONE"
Case WSASYSNOTREADY
DefaultError = "WSASYSNOTREADY: Indicates that the underlying network subsystem is not ready for network communication"
Case WSAVERNOTSUPPORTED
DefaultError = "WSAVERNOTSUPPORTED: The version of Windows Sockets support requested is not provided by this particular Windows Sockets implementation"
Case WSAEINVAL
DefaultError = "WSAEINVAL: The Windows Sockets version specified by the application is not supported by this DLL"
Case WSANOTINITIALISED
DefaultError = "WSANOTINITIALISED: A successful WSAStartup must occur before using this function"
Case WSAENETDOWN
DefaultError = "WSAENETDOWN: The Windows Sockets implementation has detected that the network subsystem has failed"
Case WSAEAFNOSUPPORT
DefaultError = "WSAEAFNOSUPPORT: The specified address family is not supported"
Case WSAEINPROGRESS
DefaultError = "WSAEINPROGRESS: A blocking Windows Sockets operation is in progress"
Case WSAEMFILE
DefaultError = "WSAEMFILE: No more file descriptors are available"
Case WSAENOBUFS
DefaultError = "WSAENOBUFS: No buffer space is available. The socket cannot be created"
Case WSAEPROTONOSUPPORT
DefaultError = "WSAEPROTONOSUPPORT: The specified protocol is not supported"
Case WSAEPROTOTYPE
DefaultError = "WSAEPROTOTYPE: The specified protocol is the wrong type for this socket"
Case WSAESOCKTNOSUPPORT
DefaultError = "WSAESOCKTNOSUPPORT: The specified socket type is not supported in this address family"
Case WSAEADDRINUSE
DefaultError = "WSAEADDRINUSE: The specified address is already in use"
Case WSAEINTR
DefaultError = "WSAEINTR: The (blocking) call was canceled using WSACancelBlockingCall"
Case WSAEADDRNOTAVAIL
DefaultError = "WSAEADDRNOTAVAIL: The specified address is not available from the local computer"
Case WSAECONNREFUSED
DefaultError = "WSAECONNREFUSED: The attempt to connect was forcefully rejected"
Case WSAEFAULT
DefaultError = "WSAEFAULT: The namelen argument is incorrect"
Case WSAEISCONN
DefaultError = "WSAEISCONN: The socket is already connected"
Case WSAENETUNREACH
DefaultError = "WSAENETUNREACH: The network cant be reached from this host at this time"
Case WSAENOTSOCK
DefaultError = "WSAENOTSOCK: The descriptor is not a socket"
Case WSAETIMEDOUT
DefaultError = "WSAETIMEDOUT: Attempt to connect timed out without establishing a connection"
Case WSAEWOULDBLOCK
DefaultError = "WSAEWOULDBLOCK: The socket is marked as nonblocking and the connection cannot be completed immediately. It is possible to select the socket while it is connecting by selecting it for writing"
Case WSAEACCES
DefaultError = "The requested address is a broadcast address, but the appropriate flag was not set"
Case WSAENETRESET
DefaultError = "The connection must be reset because the Windows Sockets implementation dropped it"
Case WSAENOTCONN
DefaultError = "The socket is not connected"
Case WSAEOPNOTSUPP
DefaultError = "MSG_OOB was specified, but the socket is not of type SOCK_STREAM"
Case WSAESHUTDOWN
DefaultError = "The socket has been shutdown it is not possible to send on a socket after shutdown has been invoked with how set to 1 or 2"
Case WSAEMSGSIZE
DefaultError = "The socket is of type SOCK_DGRAM, and the datagram is larger than the maximum supported by the Windows Sockets implementation"
Case WSAECONNABORTED
DefaultError = "The virtual circuit was aborted due to timeout or other failure"
Case WSAECONNRESET
DefaultError = "The virtual circuit was reset by the remote side"
Case Else
DefaultError = "Case unknown in TCPIP::SetLastErrorCode = " & mlngLastErrorCode
End Select
GetLastErrorCode = strAdditionalInfo & vbCrLf & DefaultError
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:
'mlngSendBufferLen and mlngRecvBufferLen.
'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(SocketID, SOL_SOCKET, SO_RCVBUF, lngBuffer, 4&)
mlngRecvBufferLen = lngBuffer
'Buffer for outgoing data
lngRetValue = getsockopt(SocketID, SOL_SOCKET, SO_SNDBUF, lngBuffer, 4&)
mlngSendBufferLen = lngBuffer
Else
'the mlngMaxMsgSize value is returned by InitWinsockService
'function from the MSocketSupport module
mlngSendBufferLen = mlngMaxMsgSize
mlngRecvBufferLen = mlngMaxMsgSize
End If
'
End Sub
'* Descrizione dell'ultimo errore
Private Property Let LastError(newValue As String)
mstrLastError = newValue
End Property
'* Indirizzo locale della socket
Private Property Set LocalHost(newValue As CRemoteHost)
Set mLocalHost = newValue
End Property
Private Sub mRemoteHost_OnChangeIPAddress()
Dim lngRetValue As Long 'value returned by the setsockopt function
If Not (RemoteHost.IP.AsInetAddress = INADDR_NONE) Then
If Not mvarProtocol = sckUDPProtocol Then Exit Sub
If Not IsCreated Then If Not Create Then Exit Sub
'
'If the IP address is a brodcasting one set the option
'
If RemoteHost.IP.Part(4) = 255 And mblnBroadcast = False Then
'
lngRetValue = setsockopt(SocketID, SOL_SOCKET, SO_BROADCAST, 1&, 4&)
'
If lngRetValue = SOCKET_ERROR Then
Call GenerateError(GetLastErrorCode("Errore in SetSockOpt"))
Else
'
mblnBroadcast = True
'
End If
'
ElseIf (Not (RemoteHost.IP.Part(4) = 255)) And (mblnBroadcast = True) Then
'
lngRetValue = setsockopt(SocketID, SOL_SOCKET, SO_BROADCAST, 0&, 4&)
'
If lngRetValue = SOCKET_ERROR Then
Call GenerateError(GetLastErrorCode("Errore in SetSockOpt"))
Else
mblnBroadcast = False
End If
End If
'
End If
End Sub
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 (mstrRecvBuffer).
'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(mstrRecvBuffer) = 0 Then Exit Function
'
If IsEmpty(maxLen) Then
maxLen = 0
End If
'
If (Not maxLen > Len(mstrRecvBuffer)) And (maxLen > 0) Then
'
strRecvData = Left$(mstrRecvBuffer, CLng(maxLen))
'
If Not blnPeek Then
mstrRecvBuffer = Mid$(mstrRecvBuffer, CLng(maxLen + 1))
End If
'
arrBuffer() = StrConv(strRecvData, vbFromUnicode)
'
Else
'
arrBuffer() = StrConv(mstrRecvBuffer, vbFromUnicode)
'
If Not blnPeek Then
mstrRecvBuffer = ""
End If
'
End If
'
If IsEmpty(VarType) Then
varData = CStr(StrConv(arrBuffer(), vbUnicode))
Else
'
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
CopyMemory blnData, arrBuffer(0), LenB(blnData)
varData = blnData
Case vbByte
Dim bytData As Byte
CopyMemory bytData, arrBuffer(0), LenB(bytData)
varData = bytData
Case vbCurrency
Dim curData As Currency
CopyMemory curData, arrBuffer(0), LenB(curData)
varData = curData
Case vbDate
Dim datData As Date
CopyMemory datData, arrBuffer(0), LenB(datData)
varData = datData
Case vbDouble
Dim dblData As Double
CopyMemory dblData, arrBuffer(0), LenB(dblData)
varData = dblData
Case vbInteger
Dim intData As Integer
CopyMemory intData, arrBuffer(0), LenB(intData)
varData = intData
Case vbLong
Dim lngData As Long
CopyMemory lngData, arrBuffer(0), LenB(lngData)
varData = lngData
Case vbSingle
Dim sngData As Single
CopyMemory sngData, arrBuffer(0), LenB(sngData)
varData = sngData
Case vbString
Dim strData As String
strData = StrConv(arrBuffer(), vbUnicode)
varData = strData
'
End Select
'
End If
'
'Added 28-MAY-2002. Thanks to Michael Freidgeim
m_lngBytesReceived = Len(mstrRecvBuffer) 'reset BytesReceived after Getdata
'
End Function
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 strTempBuffer As String 'just a temporary buffer
Dim arrBuffer() As Byte 'buffer to pass to the recv/recvfrom Winsock API function
Dim udtSockAddr As SOCK_ADDR 'socket address of the remote peer
Dim lngSockAddrLen As Long 'size of the SOCK_ADDR structure
'Prepare the buffer to pass it to the recv/recvfrom Winsock API function.
'The mlngRecvBufferLen variable was initialized during creating
'of the socket, see the vbSocket function to find out how.
ReDim arrBuffer(mlngRecvBufferLen - 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(SocketID, arrBuffer(0), mlngRecvBufferLen, 0&)
'
Else
'
'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(SocketID, arrBuffer(0), mlngRecvBufferLen, _
0&, udtSockAddr, lngSockAddrLen)
'
If Not lngBytesReceived = SOCKET_ERROR Then
'RemotePort property
RemoteHost.PortFromNetworkSpecs = udtSockAddr.sin_port
'RemoteHostIP property
RemoteHost.IP.FromInetAddress = udtSockAddr.sin_addr.S_addr
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 - mstrRecvBuffer
mstrRecvBuffer = mstrRecvBuffer & Left$(strTempBuffer, lngBytesReceived)
'Return number of received bytes.
RecvDataToBuffer = lngBytesReceived
'
ElseIf lngBytesReceived = SOCKET_ERROR Then
Call GenerateError(GetErrorDescription(Err.LastDllError))
End If
End Function
'* Indirizzo remoto della socket
Private Property Set RemoteHost(newValue As CRemoteHost)
Set mRemoteHost = newValue
End Property
Private Function SendBufferedData() As Boolean
'
'This procedure sends data from the local buffer (mstrSendBuffer).
'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 SOCK_ADDR 'address of the remote socket - for the sendto function
'
'The send/sendto function needs this value for one of its arguments
lngBufferLength = Len(mstrSendBuffer)
mblnSendFlag = True
'
'Convert data from a VB string to a byte array
arrData() = StrConv(mstrSendBuffer, vbFromUnicode)
'
If mvarProtocol = sckTCPProtocol Then
'
'just call the send function in order to send data via connection
lngRetValue = Send(SocketID, arrData(0), lngBufferLength, 0&)
'
Else
'
'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 we are here the host was resolved successfully and the RemoteHostIP
'property provides us with IP to send a UDP message to.
'
'Build the SOCK_ADDR structure to pass the remote socket address
'to the sendto function.
With udtSockAddr
.sin_addr.S_addr = RemoteHost.IP.AsInetAddress
.sin_port = RemoteHost.PortToNetworkSpecs
.sin_family = AddressFamily
End With
'
'Call the sendto function in order to send a UDP message
lngRetValue = sendto(SocketID, arrData(0), lngBufferLength, 0&, udtSockAddr, Len(udtSockAddr))
'
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 (mstrSendBuffer).
'
If Err.LastDllError <> WSAEWOULDBLOCK Then
Call GenerateError(GetErrorDescription(Err.LastDllError))
End If
Else
'
'The data were sent successfully. Raise the OnSendProgress or
'OnSendComplete event to let the client app know.
'
If Len(mstrSendBuffer) > lngRetValue Then
'
mstrSendBuffer = Mid$(mstrSendBuffer, lngRetValue + 1)
'
Else
'
mstrSendBuffer = ""
'
'---------------------------------------------
'Modified: 23-AUG-2002
'---------------------------------------------
'RaiseEvent OnSendComplete
Call PostMessage(p_lngWindowHandle, p_lngWinsockMessage, SocketID, FD_WRITE)
'---------------------------------------------
End If
'
RaiseEvent OnSendProgress(lngRetValue, Len(mstrSendBuffer))
'
End If
SendBufferedData = True
End Function
'* Contiene l'identificativo univoco attribuito dal sistema alla Socket creata
Private Property Let SocketID(newValue As Long)
mlngSocketID = newValue
End Property
Friend Sub PostGetHostEvent(ByVal lngRequestID As Long, ByVal lngHostAddress As Long, strHostName As String, Optional lngError As Long)
'
'This procedure is called by the WindowProc callback function
'from the MSocketSupport module. Think about it as about result
'returned by the ResolveHost function called from this class.
'
Dim udtAddress As SOCK_ADDR 'socket address - used by the connect Winsock API function
Dim lngRetValue As Long 'value returned by the connect Winsock API function
On Error GoTo ERROR_HANDLER
'
If lngError > 0 Then
'
'An error was occerred during resolving the host hame.
'For example: "Host not found"
'
'----------------------------------------------------------------
'Added: 28-APR-2002
'There is the case when a computer has a valid IP address
'but its name cannot be resolved. In this case the code should
'countinue the execution - we just don't need to change the
'RemoteHost property value.
'----------------------------------------------------------------
'
'Does the strHostName argument contain a valid IP address?
lngHostAddress = inet_addr(strHostName)
'
If lngHostAddress = INADDR_NONE Then 'Added: 28-APR-2002
'
'Change a value of the State property
mvarState = sckError
'Debug.Print "mvarState = sckError"
'
'Let the client app know that an error was occurred.
RaiseEvent OnError(CInt(lngError), GetErrorDescription(lngError), 0, "", "", 0, False)
'
Exit Sub
'
Else 'Added: 28-APR-2002
'
'Nothing to do here
'Both properties the RemoteHost and RemoteHostIP
'have the same value of the IP address string.
'
End If 'Added: 28-APR-2002
'
End If
'
'Check the id value - Do we really need this?
If lngRequestID = 0 Then Exit Sub
'
If lngRequestID = m_lngRequestID Then
'
'Change a value of the State property
mvarState = sckHostResolved
'Debug.Print "mvarState = sckHostResolved"
'
'Initialize the RemoteHost property
RemoteHost.IP.fromString strHostName
'
'Get pointer to the string that contains the IP address
RemoteHost.IP.FromInetAddress = lngHostAddress
'The ResolveHost function may be called from two methods
'of the class: Connect and SendData. The m_varInternalState
'variable tells us where the ResolveHost function called
'from, and thus what to do here.
'
If m_varInternalState = istConnecting Then
'
'The ResolveHost was called from the Connect method, so
'we need to continue the process of the connection establishing.
'
'Build the SOCK_ADDR structure to pass it to the connect
'Winsock API function as an address of the remote host.
With udtAddress
.sin_addr.S_addr = lngHostAddress
.sin_family = AddressFamily
.sin_port = RemoteHost.PortToNetworkSpecs
End With
'
'Call the connect Winsock API function in order to establish connection.
lngRetValue = sConnect(SocketID, udtAddress, Len(udtAddress))
'
'Since the socket we use is a non-blocking one, the connect Winsock API
'function should return a value of SOCKET_ERROR anyway.
'
If lngRetValue = SOCKET_ERROR Then
'
'The WSAEWOULDBLOCK error is OK for such a socket
'
If Not Err.LastDllError = WSAEWOULDBLOCK Then
'Modified: 31-JUL-2002
Call GenerateError(GetErrorDescription(Err.LastDllError))
Else
'Change the State property value
mvarState = sckConnecting
End If
End If
'
ElseIf m_varInternalState = istSendingDatagram Then
'
'The ResolveHost was called from the SendData method in
'the case when a message-oriented (UDP) socket is used.
'
Call SendBufferedData
'
End If
'
End If
'
Exit Sub
ERROR_HANDLER: Call GenerateErrorGenerico("PostGetHostEvent")
End Sub
Friend Sub PostSocketEvent(ByVal lngEventID As Long, Optional ByVal lngError As Long)
'
'This procedure is called by the WindowProc callback function
'from the MSocketSupport module. The lngEventID argument is an
'ID of the network event occurred for the socket. The lngError
'argument contains an error code only if an error was occurred
'during an asynchronous execution.
'
Dim lngBytesReceived As Long 'value returned by the RecvDataToBuffer function
Dim lngRetValue As Long 'value returned by the getsockname Winsock API function
Dim lngNewSocket As Long 'value returned by the accept Winsock API function
Dim udtSockAddr As SOCK_ADDR 'remote socket address for the accept Winscok API function
On Error GoTo ERROR_HANDLER
'
If lngError > 0 Then
'
'An error was occurred.
'
'Change a value of the State property
mvarState = sckError
'Debug.Print "mvarState = sckError"
'Close the socket
Call DestroySocket
'The OnError event is just for this case
RaiseEvent OnError(CInt(lngError), GetErrorDescription(lngError), 0, "", "", 0, False)
'We have nothing to do here anymore
Exit Sub
'
End If
'
Select Case lngEventID
'
Case FD_READ
'
'Debug.Print "FD_READ"
'
'Some data has arrived for this socket.
'Call the RecvDataToBuffer function that move arrived data
'from the Winsock buffer to the local one and returns number
'of bytes received.
lngBytesReceived = RecvDataToBuffer
'
'Debug.Print "Bytes received: " & lngBytesReceived
'
'The BytesReceived property contains number of bytes in
'the local buffer of the class.
m_lngBytesReceived = m_lngBytesReceived + lngBytesReceived
'
'The OnDataArrival event is just for the case when some data
'was retieved from the Winsock buffer.
If lngBytesReceived > 0 Then
RaiseEvent OnDataArrival(Len(mstrRecvBuffer))
End If
'
Case FD_WRITE
'
'This message means that the socket in a write-able
'state, that is, buffer for outgoing data of the transport
'service is empty and ready to receive data to send through
'the network.
'
'Debug.Print "FD_WRITE"
'
'If the local buffer for outgoing data (mstrSendBuffer) is
'not empty, the previous call of the send/sendto Winsock API
'function was failed. Call the SendBufferedData procedure in
'oreder to try to send that data again.
If Len(mstrSendBuffer) > 0 Then
'
Call SendBufferedData
Else
'
If mblnSendFlag Then 'Added: 12-SEP-2002
mblnSendFlag = False 'Added: 12-SEP-2002
RaiseEvent OnSendComplete 'Added: 23-AUG-2002
End If
'
End If
'
Case FD_OOB
'
'Ignored.
'
Case FD_ACCEPT
'
'When the socket is in a listening state, arrival of this message
'means that a connection request was received. Call the accept
'Winsock API function in oreder to create a new socket for the
'requested connection.
lngNewSocket = api_accept(SocketID, udtSockAddr, Len(udtSockAddr))
'
'Debug.Print lngNewSocket & ": created"
'
'Let the client application know that the request was received
'and pass with the event argument a handle of the recently created
'socket. The client application should create a new instance of
'the CSocket class, and then use the socket handle (lngNewSocket)
'to initialize its properties. Another way is to do not create
'one more instance of this class. We may close existing socket,
'and then accept the new handle:
'
' Private Sub objSocket_OnConnectionRequest(ByVal requestID As Long)
' If objSocket.State <> sckClosed Then objSocket.CloseSocket
' objSocket.Accept (requestID)
' End Sub
'
RaiseEvent OnConnectionRequest(lngNewSocket)
'
Case FD_CONNECT
'
'Arrival of this message means that the connection initiated by the call
'of the connect Winsock API function was successfully established.
'
'Get the connection local end-point parameters
'
lngRetValue = getsockname(SocketID, udtSockAddr, LenB(udtSockAddr))
'
If lngRetValue = 0 Then
'LocalPort property
LocalHost.PortFromNetworkSpecs = udtSockAddr.sin_port
LocalHost.IP.FromInetAddress = udtSockAddr.sin_addr.S_addr
End If
'
' -- Modified: 04-MAR-2002 --
'
'Change a value of the State property
mvarState = sckConnected
'
'Let the client app know that the connection was established.
RaiseEvent OnConnect
Case FD_CLOSE
'
'This message means that the remote host is closing the conection
'
'-------------------------------------------------------------------
'Modified: 20-AUG-2002
'Thanks to mreggio and other vbip.com Forum members.
'-------------------------------------------------------------------
Do
'
lngBytesReceived = RecvDataToBuffer
'
If lngBytesReceived > 0 Then
RaiseEvent OnDataArrival(Len(mstrRecvBuffer))
End If
'
Loop Until lngBytesReceived = 0 Or lngBytesReceived = SOCKET_ERROR
'
If mvarState <> sckClosing Then
mvarState = sckClosing
'If a value of the State property is not sckClosing, the
'connectoin is closing by the remote end-point of the
'connection (the FIN segment is sent by the remote host).
'In this case we need send all the remained data from the
'local buffer before to close the socket.
If Len(mstrSendBuffer) > 0 Then Call SendBufferedData
End If
'Close the socket
Call DestroySocket
'Change a value of the State property
mvarState = sckClosed
'Let the client app know that the connection is closed
RaiseEvent OnClose
'
End Select
Exit Sub
'
ERROR_HANDLER:
'
Err.Raise Err.Number, "CSocket.PostSocketEvent", Err.Description 'Modified: 15-APR-2002
'
End Sub
|
Documento generato mediante: Documentation Creator By BGSoftware |