VB en Réseau

CLIENT-SERVEUR

Pour utiliser l'exemple, il faut créer un nouveau projet sous VB et rajouter les fichiers suivants :

J'utilise une fonction CALLBACK pour intercepter les messages Windows. Or l'interface VB n'aime pas trop cela. Donc il faut utiliser l'executable pour tester ce programme.

Si vous etes en mono-poste, lancez deux fois le programme, vous en mettez un en serveur et vous connectez le client dessus.

Je précise qu'il s'agit juste d'un exemple pour comprendre le concept général : cette version ne gère qu'un seul client.

Pour toutes questions : webmaster@vbenreseau.com

ClientServeur.frm

Option Explicit
Private LocalServer As SOCK_ADDR
Private rmtserver As SOCK_ADDR
Private Sub Client_Click()

Dim wsadata As WSA_DATA
Dim sock As Long
Dim CR As Long

Form1.Caption = "Client"
CR = WSAStartup(&H101, wsadata)
If CR <> 0 Then
MsgBox "Mauvaise version de Winsock.dll"
Exit Sub
End If

sock = Socket(AF_INET, SOCK_STREAM, 0)
If sock < 0 Then
MsgBox "Erreur sur la creation du socket = " & WSAGetLastError()
Exit Sub
End If

List1.AddItem sock & " : Client"

rmtserver.sin_family = AF_INET
rmtserver.sin_port = htons(Port.Text)
rmtserver.sin_addr.S_addr = inet_addr(IP.Text)
rmtserver.sin_zero(0) = 0
CR = connect(sock, rmtserver, Len(rmtserver))
If CR < 0 Then
MsgBox "Erreur sur Connect : " & WSAGetLastError()
FermerSocket sock
Exit Sub
End If

CR = WSAAsyncSelect(sock, Form1.hwnd, WM_USER + 1, FD_READ Or FD_CLOSE)
If CR < 0 Then
MsgBox "Erreur sur WSAAsyncSelect = " & WSAGetLastError()
FermerSocket sock
Exit Sub
End If

End Sub
Private Sub Emission_KeyPress(KeyAscii As Integer)

Dim i As Integer
Dim sock As Long
Dim message As String

If KeyAscii = vbKeyReturn Then
message = Emission.Text
For i = 0 To List1.ListCount - 1
sock = Left(Form1.List1.List(i), InStr(1, Form1.List1.List(i), " ") - 1)
message = sock & ":>" & Emission.Text
Reception.Text = message & vbCrLf & Reception.Text
Envoyer sock, message
Next

Emission.Text = ""
End If

End Sub
Private Sub Form_Load()

Call SetHook(hwnd, True)
IP.Text = "127.0.0.1"
Port.Text = 2000

End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

Call SetHook(hwnd, False)

End Sub
Private Sub Fin_Click()

Dim i As Integer
Dim sock As Long

For i = 1 To List1.ListCount - 1
sock = Left(Form1.List1.List(i), InStr(1, Form1.List1.List(i), " ") - 1)
FermerSocket sock
Next

Serveur.Enabled = True

End Sub
Private Sub Serveur_Click()

Dim CR As Long
Dim wsadata As WSA_DATA
Dim sock As Long

Form1.Caption = "Serveur"
CR = WSAStartup(&H101, wsadata)
If CR <> 0 Then
MsgBox "Mauvaise version de Winsock.dll"
Exit Sub
End If

sock = Socket(AF_INET, SOCK_STREAM, 0)
If sock < 0 Then
MsgBox "Erreur sur la creation du socket = " & WSAGetLastError()
Exit Sub
End If

LocalServer.sin_family = AF_INET
LocalServer.sin_port = htons(Port.Text)
LocalServer.sin_addr.S_addr = INADDR_ANY
LocalServer.sin_zero(0) = 0
CR = bind(sock, LocalServer, Len(LocalServer))
If CR < 0 Then
MsgBox "Erreur sur bind : " & WSAGetLastError()
FermerSocket sock
Exit Sub
End If

CR = listen(sock, 2)
If CR < 0 Then
MsgBox "Erreur sur listen : " & WSAGetLastError()
FermerSocket sock
Exit Sub
End If

CR = WSAAsyncSelect(sock, Form1.hwnd, WM_USER + 1, FD_READ Or FD_CLOSE Or FD_ACCEPT)
If CR < 0 Then
MsgBox "Erreur sur WSAAsyncSelect = " & WSAGetLastError()
FermerSocket sock
Exit Sub
End If

Serveur.Enabled = False

End Sub
Public Function VbAccept(ByVal hwnd As Long, ByVal msg As Long, _
ByVal wParam As Long, ByVal lParam As Long)

Dim AdrIP As String
Dim message As String
Dim sock As Long

AdrIP = ""
sock = Accepter(wParam, rmtserver, AdrIP)

List1.AddItem sock & " : " & AdrIP

message = "Connection etablie"
Envoyer sock, message

End Function
Function VbClose(ByVal hwnd As Long, ByVal msg As Long, _
ByVal wParam As Long, ByVal lParam As Long)

Dim i As Long

For i = 0 To List1.ListCount - 1
If Left(List1.List(i), InStr(1, List1.List(i), " ") - 1) = wParam Then
List1.RemoveItem i
Exit For
End If
Next

End Function
Public Function VbRecv(ByVal hwnd As Long, ByVal msg As Long, _
ByVal wParam As Long, ByVal lParam As Long)

Dim message As String
Dim sock As Long
Dim i As Long

message = Recevoir(wParam)
Reception.Text = message & vbCrLf & Reception.Text

If List1.ListCount > 1 Then
For i = 0 To List1.ListCount - 1
sock = Left(List1.List(i), InStr(1, List1.List(i), " ") - 1)
Envoyer sock, message
Next
End If

End Function

WinsockDefs.bas

Option Explicit

Public Const WSANOERROR = 0

'Address families.

Public Const AF_UNSPEC = 0
Public Const AF_UNIX = 1
Public Const AF_INET = 2
Public Const AF_IMPLINK = 3
Public Const AF_PUP = 4
Public Const AF_CHAOS = 5
Public Const AF_IPX = 6
Public Const AF_NS = 6
Public Const AF_ISO = 7
Public Const AF_OSI = AF_ISO
Public Const AF_ECMA = 8
Public Const AF_DATAKIT = 9
Public Const AF_CCITT = 10
Public Const AF_SNA = 11
Public Const AF_DECnet = 12
Public Const AF_DLI = 13
Public Const AF_LAT = 14
Public Const AF_HYLINK = 15
Public Const AF_APPLETALK = 16
Public Const AF_NETBIOS = 17
Public Const AF_VOICEVIEW = 18
Public Const AF_FIREFOX = 19
Public Const AF_UNKNOWN1 = 20
Public Const AF_BAN = 21
Public Const AF_MAX = 22

Public Const PF_UNSPEC = AF_UNSPEC
Public Const PF_UNIX = AF_UNIX
Public Const PF_INET = AF_INET
Public Const PF_IMPLINK = AF_IMPLINK
Public Const PF_PUP = AF_PUP
Public Const PF_CHAOS = AF_CHAOS
Public Const PF_NS = AF_NS
Public Const PF_IPX = AF_IPX
Public Const PF_ISO = AF_ISO
Public Const PF_OSI = AF_OSI
Public Const PF_ECMA = AF_ECMA
Public Const PF_DATAKIT = AF_DATAKIT
Public Const PF_CCITT = AF_CCITT
Public Const PF_SNA = AF_SNA
Public Const PF_DECnet = AF_DECnet
Public Const PF_DLI = AF_DLI
Public Const PF_LAT = AF_LAT
Public Const PF_HYLINK = AF_HYLINK
Public Const PF_APPLETALK = AF_APPLETALK
Public Const PF_VOICEVIEW = AF_VOICEVIEW
Public Const PF_FIREFOX = AF_FIREFOX
Public Const PF_UNKNOWN1 = AF_UNKNOWN1
Public Const PF_BAN = AF_BAN
Public Const PF_MAX = AF_MAX

'Public Const AF_INET = 2
'Public Const PF_INET = AF_INET
Public Const IPPROTO_IP = 0
Public Const IPPROTO_ICMP = 1
Public Const IPPROTO_IGMP = 2
Public Const IPPROTO_GGP = 3
Public Const IPPROTO_TCP = 6
Public Const IPPROTO_PUP = 12
Public Const IPPROTO_UDP = 17
Public Const IPPROTO_IDP = 22
Public Const IPPROTO_ND = 77

'/*
' * bit values and indices for FD_XXX network events
' */
Public Const FD_READ = &H1
Public Const FD_WRITE = &H2
Public Const FD_OOB = &H4
Public Const FD_ACCEPT = &H8
Public Const FD_CONNECT = &H10
Public Const FD_CLOSE = &H20

'Define socket types
Public Const SOCK_STREAM = 1 'Stream socket
Public Const SOCK_DGRAM = 2 'Datagram socket
Public Const SOCK_RAW = 3 'Raw data socket
Public Const SOCK_RDM = 4 'Reliable Delivery socket
Public Const SOCK_SEQPACKET = 5 'Sequenced Packet socket

Public Const INADDR_ANY = &H0
Public Const INADDR_LOOPBACK = &H7F000001
Public Const INADDR_BROADCAST = &HFFFF
Public Const INADDR_NONE = &HFFFF

'Public Const SOCK_STREAM = 1&
Public Const WSADESCRIPTION_LEN = 256
Public Const WSASYS_STATUS_LEN = 128

Public Const INVALID_SOCKET = -1&
Public Const SOCKET_ERROR = -1&
'Public Const INADDR_NONE = &HFFFFFFFF

' All Windows Sockets error constants are biased by WSABASEERR from the "normal"

Public Const WSABASEERR = 10000

' Windows Sockets definitions of regular Microsoft C error constants

Public Const WSAEINTR = (WSABASEERR + 4)
Public Const WSAEBADF = (WSABASEERR + 9)
Public Const WSAEACCES = (WSABASEERR + 13)
Public Const WSAEFAULT = (WSABASEERR + 14)
Public Const WSAEINVAL = (WSABASEERR + 22)
Public Const WSAEMFILE = (WSABASEERR + 24)

' Windows Sockets definitions of regular Berkeley error constants

Public Const WSAEWOULDBLOCK = (WSABASEERR + 35)
Public Const WSAEINPROGRESS = (WSABASEERR + 36)
Public Const WSAEALREADY = (WSABASEERR + 37)
Public Const WSAENOTSOCK = (WSABASEERR + 38)
Public Const WSAEDESTADDRREQ = (WSABASEERR + 39)
Public Const WSAEMSGSIZE = (WSABASEERR + 40)
Public Const WSAEPROTOTYPE = (WSABASEERR + 41)
Public Const WSAENOPROTOOPT = (WSABASEERR + 42)
Public Const WSAEPROTONOSUPPORT = (WSABASEERR + 43)
Public Const WSAESOCKTNOSUPPORT = (WSABASEERR + 44)
Public Const WSAEOPNOTSUPP = (WSABASEERR + 45)
Public Const WSAEPFNOSUPPORT = (WSABASEERR + 46)
Public Const WSAEAFNOSUPPORT = (WSABASEERR + 47)
Public Const WSAEADDRINUSE = (WSABASEERR + 48)
Public Const WSAEADDRNOTAVAIL = (WSABASEERR + 49)
Public Const WSAENETDOWN = (WSABASEERR + 50)
Public Const WSAENETUNREACH = (WSABASEERR + 51)
Public Const WSAENETRESET = (WSABASEERR + 52)
Public Const WSAECONNABORTED = (WSABASEERR + 53)
Public Const WSAECONNRESET = (WSABASEERR + 54)
Public Const WSAENOBUFS = (WSABASEERR + 55)
Public Const WSAEISCONN = (WSABASEERR + 56)
Public Const WSAENOTCONN = (WSABASEERR + 57)
Public Const WSAESHUTDOWN = (WSABASEERR + 58)
Public Const WSAETOOMANYREFS = (WSABASEERR + 59)
Public Const WSAETIMEDOUT = (WSABASEERR + 60)
Public Const WSAECONNREFUSED = (WSABASEERR + 61)
Public Const WSAELOOP = (WSABASEERR + 62)
Public Const WSAENAMETOOLONG = (WSABASEERR + 63)
Public Const WSAEHOSTDOWN = (WSABASEERR + 64)
Public Const WSAEHOSTUNREACH = (WSABASEERR + 65)
Public Const WSAENOTEMPTY = (WSABASEERR + 66)
Public Const WSAEPROCLIM = (WSABASEERR + 67)
Public Const WSAEUSERS = (WSABASEERR + 68)
Public Const WSAEDQUOT = (WSABASEERR + 69)
Public Const WSAESTALE = (WSABASEERR + 70)
Public Const WSAEREMOTE = (WSABASEERR + 71)

Public Const WSAEDISCON = (WSABASEERR + 101)

' Extended Windows Sockets error constant definitions

Public Const WSASYSNOTREADY = (WSABASEERR + 91)
Public Const WSAVERNOTSUPPORTED = (WSABASEERR + 92)
Public Const WSANOTINITIALISED = (WSABASEERR + 93)

' Error return codes from gethostbyname() and gethostbyaddr()
' (when using the resolver). Note that these errors are
' retrieved via WSAGetLastError() and must therefore follow
' the rules for avoiding clashes with error numbers from
' specific implementations or language run-time systems.
' For this reason the codes are based at WSABASEERR+1001.
' Note also that [WSA]NO_ADDRESS is defined only for
' compatibility purposes.

' Authoritative Answer: Host not found

Public Const WSAHOST_NOT_FOUND = (WSABASEERR + 1001)
Public Const HOST_NOT_FOUND = WSAHOST_NOT_FOUND

' Non-Authoritative: Host not found, or SERVERFAIL

Public Const WSATRY_AGAIN = (WSABASEERR + 1002)
Public Const TRY_AGAIN = WSATRY_AGAIN

' Non recoverable errors, FORMERR, REFUSED, NOTIMP

Public Const WSANO_RECOVERY = (WSABASEERR + 1003)
Public Const NO_RECOVERY = WSANO_RECOVERY

' Valid name, no data record of requested type

Public Const WSANO_DATA = (WSABASEERR + 1004)
Public Const NO_DATA = WSANO_DATA

' no address, look for MX record

Public Const WSANO_ADDRESS = WSANO_DATA
Public Const NO_ADDRESS = WSANO_ADDRESS

' Windows Sockets errors redefined as regular Berkeley error constants.
' These are commented out in Windows NT to avoid conflicts with errno.h.
' Use the WSA constants instead.

Public Const EWOULDBLOCK = WSAEWOULDBLOCK
Public Const EINPROGRESS = WSAEINPROGRESS
Public Const EALREADY = WSAEALREADY
Public Const ENOTSOCK = WSAENOTSOCK
Public Const EDESTADDRREQ = WSAEDESTADDRREQ
Public Const EMSGSIZE = WSAEMSGSIZE
Public Const EPROTOTYPE = WSAEPROTOTYPE
Public Const ENOPROTOOPT = WSAENOPROTOOPT
Public Const EPROTONOSUPPORT = WSAEPROTONOSUPPORT
Public Const ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT
Public Const EOPNOTSUPP = WSAEOPNOTSUPP
Public Const EPFNOSUPPORT = WSAEPFNOSUPPORT
Public Const EAFNOSUPPORT = WSAEAFNOSUPPORT
Public Const EADDRINUSE = WSAEADDRINUSE
Public Const EADDRNOTAVAIL = WSAEADDRNOTAVAIL
Public Const ENETDOWN = WSAENETDOWN
Public Const ENETUNREACH = WSAENETUNREACH
Public Const ENETRESET = WSAENETRESET
Public Const ECONNABORTED = WSAECONNABORTED
Public Const ECONNRESET = WSAECONNRESET
Public Const ENOBUFS = WSAENOBUFS
Public Const EISCONN = WSAEISCONN
Public Const ENOTCONN = WSAENOTCONN
Public Const ESHUTDOWN = WSAESHUTDOWN
Public Const ETOOMANYREFS = WSAETOOMANYREFS
Public Const ETIMEDOUT = WSAETIMEDOUT
Public Const ECONNREFUSED = WSAECONNREFUSED
Public Const ELOOP = WSAELOOP
Public Const ENAMETOOLONG = WSAENAMETOOLONG
Public Const EHOSTDOWN = WSAEHOSTDOWN
Public Const EHOSTUNREACH = WSAEHOSTUNREACH
Public Const ENOTEMPTY = WSAENOTEMPTY
Public Const EPROCLIM = WSAEPROCLIM
Public Const EUSERS = WSAEUSERS
Public Const EDQUOT = WSAEDQUOT
Public Const ESTALE = WSAESTALE
Public Const EREMOTE = WSAEREMOTE

Type WSA_DATA
wVersion As Integer
wHighVersion As Integer
strDescription(WSADESCRIPTION_LEN + 1) As Byte
strSystemStatus(WSASYS_STATUS_LEN + 1) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type

Type IN_ADDR
S_addr As Long
End Type

Type SOCK_ADDR
sin_family As Integer
sin_port As Integer
sin_addr As IN_ADDR
sin_zero(0 To 7) As Byte
End Type

Type Inet_Adress
Byte4 As String * 1
Byte3 As String * 1
Byte2 As String * 1
Byte1 As String * 1
End Type

Public Const FD_SETSIZE = 64
Type FD_SET
fd_count As Long
fd_array(0 To FD_SETSIZE - 1) As Long
End Type

Type TIME_VAL
tv_sec As Long
tv_usec As Long
End Type

Declare Function bind Lib "wsock32" _
(ByVal s As Long, Addr As SOCK_ADDR, ByVal namelen As Long) As Long
Declare Function closesocket Lib "wsock32" _
(ByVal s As Long) As Long
Declare Function connect Lib "wsock32" _
(ByVal s As Long, name As SOCK_ADDR, ByVal namelen As Integer) As Long
Declare Function inet_addr Lib "wsock32" _
(ByVal cp As String) As Long
Declare Function htons Lib "wsock32" _
(ByVal hostshort As Integer) As Integer
Declare Function recv Lib "wsock32" _
(ByVal s As Long, buffer As Any, ByVal length As Long, ByVal flags As Long) As Long
Declare Function send Lib "wsock32" _
(ByVal s As Long, buffer As Any, ByVal length As Long, ByVal flags As Long) As Long
Declare Function shutdown Lib "wsock32" (ByVal s As Long, ByVal how As Long) As Long
Declare Function sselect Lib "wsock32" Alias "select" _
(ByVal nfds As Long, readfds As FD_SET, writefds As FD_SET,_
exceptfds As FD_SET, timeout As TIME_VAL) As Long
Declare Function Socket Lib "wsock32" Alias "socket" _
(ByVal af As Long, ByVal type_specification As Long, ByVal protocol As Long) As Long
Declare Function WSACancelBlockingCall Lib "wsock32" () As Long
Declare Function WSACleanUp Lib "wsock32" Alias "WSACleanup" () As Long
Declare Function WSAGetLastError Lib "wsock32" () As Long
Declare Function WSAStartup Lib "wsock32" _
(ByVal wVersionRequired As Integer, wsData As WSA_DATA) As Long

Declare Function WSAAsyncSelect Lib "wsock32.dll" _
(ByVal s As Long, ByVal hwnd As Long, _
ByVal wMsg As Integer, ByVal lEvent As Long) As Integer

Declare Function listen Lib "wsock32.dll" _
(ByVal s As Long, ByVal backlog As Integer) As Integer

Declare Function accept Lib "wsock32.dll" _
(ByVal sock As Long, ByRef Addr As SOCK_ADDR, ByRef namelen As Integer) As Long
Declare Function inet_ntoa Lib "wsock32.dll" (ByVal inet As Long) As Long

Public Sub FermerSocket(sock As Long)

Dim lngResult As Long

If sock <> 0 Then
lngResult = shutdown(sock, 2)
lngResult = closesocket(sock)
End If
lngResult = WSACancelBlockingCall
lngResult = WSACleanUp
sock = 0

End Sub
Public Function Accepter(sock As Long, rmtserver As SOCK_ADDR, AdrIP As String) As Long

Dim IPStruct As Inet_Adress

Accepter = accept(sock, rmtserver, Len(rmtserver))

CopyMemory IPStruct, rmtserver.sin_addr.S_addr, 4
AdrIP = CStr(Asc(IPStruct.Byte4)) & "." & _
CStr(Asc(IPStruct.Byte3)) & "." & _
CStr(Asc(IPStruct.Byte2)) & "." & _
CStr(Asc(IPStruct.Byte1))

End Function
Public Function Recevoir(sock As Long) As String

Dim CR As Long
Const MAX_BUFF_SIZE = 10000
Dim buff(0 To MAX_BUFF_SIZE) As Byte

CR = recv(sock, buff(0), MAX_BUFF_SIZE, 0)

If CR < 0 Then
MsgBox "Erreur sur recv = " & WSAGetLastError()
FermerSocket sock
Exit Function
End If
buff(CR) = 0

Recevoir = Left(StrConv(buff(), vbUnicode), CR)

End Function
Public Sub Envoyer(sock As Long, message As String)

Dim CR As Long

CR = send(sock, ByVal message, Len(message), 0)
If CR < 0 Then
MsgBox "Erreur sur l'envoi du message = " & WSAGetLastError()
FermerSocket sock
Exit Sub
End If

End Sub

Subclass.bas

Option Explicit

Public Const WM_USER = &H400

Public Const GWL_WNDPROC = (-4)
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Public origWndProc As Long
Public Sub SetHook(hwnd, bSet As Boolean)

If bSet Then
origWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf AppWndProc)
ElseIf origWndProc Then
Dim lRet As Long
lRet = SetWindowLong(hwnd, GWL_WNDPROC, origWndProc)
End If

End Sub
Public Function AppWndProc(ByVal hwnd As Long, ByVal msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

Select Case msg
Case WM_USER + 1
Select Case LoWord(lParam)
Case FD_READ
Form1.VbRecv hwnd, msg, wParam, lParam
Case FD_CLOSE
Form1.VbClose hwnd, msg, wParam, lParam
Case FD_ACCEPT
Form1.VbAccept hwnd, msg, wParam, lParam
End Select
End Select
AppWndProc = CallWindowProc(origWndProc, hwnd, msg, wParam, lParam)

End Function
Public Function LoWord(ByVal LongIn As Long) As Integer

Call CopyMemory(LoWord, LongIn, 2)

End Function
Public Function HiWord(ByVal LongIn As Long) As Integer

Call CopyMemory(HiWord, ByVal (VarPtr(LongIn) + 2), 2)

End Function