Soyez le premier à donner votre avis sur cette source.
Vue 8 819 fois - Téléchargée 1 042 fois
Option Explicit Public smessageEcho As String Public sVersion '---------------------------------------------- '-- Recherche l'IP du poste Public Const MAX_WSADescription = 256 Public Const MAX_WSASYSStatus = 128 Public Const ERROR_SUCCESS As Long = 0 Public Const WS_VERSION_REQD As Long = &H101 Public Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF& Public Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF& Public Const MIN_SOCKETS_REQD As Long = 1 Public Const SOCKET_ERROR As Long = -1 '---------------------------------------------- Public Type hostent hName As Long hAliases As Long hAddrType As Integer hLen As Integer hAddrList As Long End Type '---------------------------------------------- Public Type WSADATA wVersion As Integer wHighVersion As Integer szDescription(0 To MAX_WSADescription) As Byte szSystemStatus(0 To MAX_WSASYSStatus) As Byte wMaxSockets As Integer wMaxUDPDG As Integer dwVendorInfo As Long End Type '---------------------------------------------- Public Declare Function WSAGetLastError Lib "wsock32.dll" () As Long Public Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired As Long, IpWSADATA As WSADATA) As Long Public Declare Function WSACleanup Lib "wsock32.dll" () As Long Public Declare Function gethostname Lib "wsock32.dll" (ByVal szHost As String, ByVal dwHostLen As Long) As Long Public Declare Function gethostbyname Lib "wsock32.dll" (ByVal szHost As String) As Long Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long) '---------------------------------------------- '-- Détermine l'adresse M.A.C. Public Const NCBASTAT As Long = &H33 Public Const NCBNAMSZ As Long = 16 Public Const HEAP_ZERO_MEMORY As Long = &H8 Public Const HEAP_GENERATE_EXCEPTIONS As Long = &H4 Public Const NCBRESET As Long = &H32 '---------------------------------------------- Public Type NET_CONTROL_BLOCK 'NCB ncb_command As Byte ncb_retcode As Byte ncb_lsn As Byte ncb_num As Byte ncb_buffer As Long ncb_length As Integer ncb_callname As String * NCBNAMSZ ncb_name As String * NCBNAMSZ ncb_rto As Byte ncb_sto As Byte ncb_post As Long ncb_lana_num As Byte ncb_cmd_cplt As Byte ncb_reserve(9) As Byte ncb_event As Long End Type '---------------------------------------------- Public Type ADAPTER_STATUS adapter_address(5) As Byte rev_major As Byte reserved0 As Byte adapter_type As Byte rev_minor As Byte duration As Integer frmr_recv As Integer frmr_xmit As Integer iframe_recv_err As Integer xmit_aborts As Integer xmit_success As Long recv_success As Long iframe_xmit_err As Integer recv_buff_unavail As Integer t1_timeouts As Integer ti_timeouts As Integer Reserved1 As Long free_ncbs As Integer max_cfg_ncbs As Integer max_ncbs As Integer xmit_buf_unavail As Integer max_dgram_size As Integer pending_sess As Integer max_cfg_sess As Integer max_sess As Integer max_sess_pkt_size As Integer name_count As Integer End Type '---------------------------------------------- Public Type NAME_BUFFER name As String * NCBNAMSZ name_num As Integer name_flags As Integer End Type '---------------------------------------------- Public Type ASTAT adapt As ADAPTER_STATUS NameBuff(30) As NAME_BUFFER End Type '---------------------------------------------- Public Declare Function Netbios Lib "netapi32.dll" (pncb As NET_CONTROL_BLOCK) As Byte Public Declare Function GetProcessHeap Lib "kernel32" () As Long Public Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long Public Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, IpMem As Any) As Long '---------------------------------------------- '-- Déclaration pour la fonction Ping Public Const IP_STATUS_BASE = 11000 Public Const IP_SUCCESS = 0 Public Const IP_BUF_TOO_SMALL = (11000 + 1) Public Const IP_DEST_NET_UNREACHABLE = (11000 + 2) Public Const IP_DEST_HOST_UNREACHABLE = (11000 + 3) Public Const IP_DEST_PROT_UNREACHABLE = (11000 + 4) Public Const IP_DEST_PORT_UNREACHABLE = (11000 + 5) Public Const IP_NO_RESOURCES = (11000 + 6) Public Const IP_BAD_OPTION = (11000 + 7) Public Const IP_HW_ERROR = (11000 + 8) Public Const IP_PACKET_TOO_BIG = (11000 + 9) Public Const IP_REQ_TIMED_OUT = (11000 + 10) Public Const IP_BAD_REQ = (11000 + 11) Public Const IP_BAD_ROUTE = (11000 + 12) Public Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13) Public Const IP_TTL_EXPIRED_REASSEM = (11000 + 14) Public Const IP_PARAM_PROBLEM = (11000 + 15) Public Const IP_SOURCE_QUENCH = (11000 + 16) Public Const IP_OPTION_TOO_BIG = (11000 + 17) Public Const IP_BAD_DESTINATION = (11000 + 18) Public Const IP_ADDR_DELETED = (11000 + 19) Public Const IP_SPEC_MTU_CHANGE = (11000 + 20) Public Const IP_MTU_CHANGE = (11000 + 21) Public Const IP_UNLOAD = (11000 + 22) Public Const IP_ADDR_ADDED = (11000 + 23) Public Const IP_GENERAL_FAILURE = (11000 + 50) Public Const MAX_IP_STATUS = 11000 + 50 Public Const IP_PENDING = (11000 + 255) Public Const PING_TIMEOUT = 200 '---------------------------------------------- Public Type ICMP_OPTIONS Ttl As Byte Tos As Byte Flags As Byte OptionsSize As Byte OptionsData As Long End Type '---------------------------------------------- Dim ICMPOPT As ICMP_OPTIONS '---------------------------------------------- Public Type ICMP_ECHO_REPLY Address As Long status As Long RoundTripTime As Long DataSize As Integer Reserved As Integer DataPointer As Long Options As ICMP_OPTIONS Data As String * 250 End Type '---------------------------------------------- Public Declare Function IcmpCreateFile Lib "Icmp.dll" () As Long Public Declare Function IcmpCloseHandle Lib "Icmp.dll" (ByVal IcmpHandle As Long) As Long Public Declare Function IcmpSendEcho Lib "Icmp.dll" (ByVal IcmpHandle As Long, _ ByVal DestinationAddress As Long, ByVal RequestData As String, _ ByVal RequestSize As Integer, ByVal RequestOptions As Long, _ ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long, _ ByVal Timeout As Long) As Long Public Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long) '---------------------------------------------- '-- Recherche de l'adresse du poste cible : Declare Function inet_addr Lib "wsock32.dll" (ByVal addr As String) As Long Declare Function gethostbyaddr Lib "wsock32.dll" (addr As Long, ByVal addr_len As Long, _ ByVal addr_type As Long) As Long Public Const AF_INET = 2 '---------------------------------------------- Function AddressStringToLong(ByVal tmp As String) As Long Dim i As Integer Dim parts(1 To 4) As String i = 0 While InStr(tmp, ".") > 0 i = i + 1 parts(i) = Mid(tmp, 1, InStr(tmp, ".") - 1) tmp = Mid(tmp, InStr(tmp, ".") + 1) Wend i = i + 1 parts(i) = tmp If i <> 4 Then AddressStringToLong = 0 Exit Function End If AddressStringToLong = Val("&H" & Right("00" & Hex(parts(4)), 2) & _ Right("00" & Hex(parts(3)), 2) & _ Right("00" & Hex(parts(2)), 2) & _ Right("00" & Hex(parts(1)), 2)) End Function '---------------------------------------------- Public Function GetIPAddress() As String Dim sHostName As String * 256 Dim lpHost As Long Dim HOST As hostent Dim dwIPAddr As Long Dim tmpIPAddr() As Byte Dim i As Integer Dim sIPAddr As String If Not SocketsInitialize() Then GetIPAddress = "" Exit Function End If '-- Si echec de GetHostName(): If gethostname(sHostName, 256) = SOCKET_ERROR Then GetIPAddress = "" SocketsCleanup Exit Function End If sHostName = Trim$(sHostName) lpHost = gethostbyname(sHostName) '-- pas de réponse du sockets: If lpHost = 0 Then GetIPAddress = "" SocketsCleanup Exit Function End If CopyMemory HOST, lpHost, Len(HOST) CopyMemory dwIPAddr, HOST.hAddrList, 4 ReDim tmpIPAddr(1 To HOST.hLen) CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen '-- Construit l'adr. IP sous la forme xx.xx.xx.xx For i = 1 To HOST.hLen sIPAddr = sIPAddr & tmpIPAddr(i) & "." Next '-- Enlève le dernier "." GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1) SocketsCleanup End Function '---------------------------------------------- Public Function GetIPHostName() As String Dim sHostName As String * 256 If Not SocketsInitialize() Then GetIPHostName = "" Exit Function End If If gethostname(sHostName, 256) = SOCKET_ERROR Then GetIPHostName = "" '-- RAPPEL: on peux extraire l'erreur via '-- Str$(WSAGetLastError()) SocketsCleanup Exit Function End If GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1) SocketsCleanup End Function '---------------------------------------------- Public Function GetMACAddress() As String Dim tmp As String Dim pASTAT As Long Dim NCB As NET_CONTROL_BLOCK Dim AST As ASTAT NCB.ncb_command = NCBRESET Call Netbios(NCB) NCB.ncb_callname = "* " NCB.ncb_command = NCBASTAT NCB.ncb_lana_num = 0 NCB.ncb_length = Len(AST) pASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, NCB.ncb_length) If pASTAT = 0 Then Debug.Print "L'allocation de mémoire à échoué!" Exit Function End If NCB.ncb_buffer = pASTAT Call Netbios(NCB) CopyMemory AST, NCB.ncb_buffer, Len(AST) tmp = Format$(Hex(AST.adapt.adapter_address(0)), "00") & "" & _ Format$(Hex(AST.adapt.adapter_address(1)), "00") & "" & _ Format$(Hex(AST.adapt.adapter_address(2)), "00") & "" & _ Format$(Hex(AST.adapt.adapter_address(3)), "00") & "" & _ Format$(Hex(AST.adapt.adapter_address(4)), "00") & "" & _ Format$(Hex(AST.adapt.adapter_address(5)), "00") HeapFree GetProcessHeap(), 0, pASTAT GetMACAddress = tmp End Function '---------------------------------------------- Public Function GetStatusCode(status As Long) As String Dim msg As String Select Case status Case IP_SUCCESS: msg = "ip success" Case IP_BUF_TOO_SMALL: msg = "ip buf too_small" Case IP_DEST_NET_UNREACHABLE: msg = "ip dest net unreachable" Case IP_DEST_HOST_UNREACHABLE: msg = "ip dest host unreachable" Case IP_DEST_PROT_UNREACHABLE: msg = "ip dest prot unreachable" Case IP_DEST_PORT_UNREACHABLE: msg = "ip dest port unreachable" Case IP_NO_RESOURCES: msg = "ip no resources" Case IP_BAD_OPTION: msg = "ip bad option" Case IP_HW_ERROR: msg = "ip hw_error" Case IP_PACKET_TOO_BIG: msg = "ip packet too big" Case IP_REQ_TIMED_OUT: msg = "ip req timed out" Case IP_BAD_REQ: msg = "ip bad req" Case IP_BAD_ROUTE: msg = "ip bad route" Case IP_TTL_EXPIRED_TRANSIT: msg = "ip ttl expired transit" Case IP_TTL_EXPIRED_REASSEM: msg = "ip ttl expired reassem" Case IP_PARAM_PROBLEM: msg = "ip param problem" Case IP_SOURCE_QUENCH: msg = "ip source quench" Case IP_OPTION_TOO_BIG: msg = "ip option too big" Case IP_BAD_DESTINATION: msg = "ip bad destination" Case IP_ADDR_DELETED: msg = "ip addr deleted" Case IP_SPEC_MTU_CHANGE: msg = "ip spec mtu change" Case IP_MTU_CHANGE: msg = "ip mtu change" Case IP_UNLOAD: msg = "ip unload" Case IP_ADDR_ADDED: msg = "ip addr added" Case IP_GENERAL_FAILURE: msg = "ip general failure" Case IP_PENDING: msg = "ip pending" Case PING_TIMEOUT: msg = "ping timeout" Case Else: msg = "unknown msg returned" End Select GetStatusCode = CStr(status) & "[" & msg & "]" End Function '---------------------------------------------- Public Function HiByte(ByVal wParam As Integer) HiByte = wParam \ &H100 And &HFF& End Function '---------------------------------------------- Public Function LoByte(ByVal wParam As Integer) LoByte = wParam And &HFF& End Function '--------------------------------------------- Public Function Ping(szAddress As String, ECHO As ICMP_ECHO_REPLY) As Long Dim hPort As Long Dim dwAddress As Long Dim sDataToSend As String Dim iOpt As Long sDataToSend = smessageEcho dwAddress = AddressStringToLong(szAddress) hPort = IcmpCreateFile() If IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), 0, ECHO, Len(ECHO), PING_TIMEOUT) Then Ping = ECHO.RoundTripTime Else: Ping = ECHO.status * -1 End If Call IcmpCloseHandle(hPort) End Function '---------------------------------------------- Public Function SocketsCleanup() As Boolean Dim X As Long X = WSACleanup() If X <> 0 Then SocketsCleanup = False Else SocketsCleanup = True End If End Function '---------------------------------------------- Public Function SocketsInitialize() As Boolean Dim WSAD As WSADATA Dim X As Integer Dim szLoByte As String, szHiByte As String, szBuf As String X = WSAStartup(WS_VERSION_REQD, WSAD) If X <> 0 Then SocketsInitialize = False Exit Function End If If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _ (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _ HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then szHiByte = Trim$(Str$(HiByte(WSAD.wVersion))) szLoByte = Trim$(Str$(LoByte(WSAD.wVersion))) sVersion = "La version des sockets Windows est " & szLoByte & "." & szHiByte SocketsInitialize = False Exit Function End If '-- Erreur car il faut un minimum de '-- Sockets disponibles (MIN_SOCKETS_REQD) If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then SocketsInitialize = False Exit Function End If SocketsInitialize = True End Function '---------------------------------------------- Function vbGetHostByAddress(ByVal sAddress As String) As String Dim lAddress As Long Dim PointerToMemoryLocation As Long Dim HostName As String Dim hostent As hostent '-- Vous devez d'abord transformer cette chaîne IP '-- en un nombre utilisable par les sockets: lAddress = inet_addr(sAddress) '-- L'adresse IP se transforme en nom DNS via GetHostByAddr(): PointerToMemoryLocation = gethostbyaddr(lAddress, 4, AF_INET) If PointerToMemoryLocation <> 0 Then CopyMemory hostent, ByVal PointerToMemoryLocation, Len(hostent) '-- Vous devez créer la variable avec 256 * la valeur 0 HostName = String(256, 0) '-- Copie vers la variables HostName CopyMemory ByVal HostName, ByVal hostent.hName, 256 If HostName = "" Then vbGetHostByAddress = "Impossible d'établir un nom DNS !" vbGetHostByAddress = Left(HostName, InStr(HostName, Chr(0)) - 1) Else '-- Aucune entrée dans la base répartie du service '-- des nom de domaine: vbGetHostByAddress = "Aucune entrée DNS !" End If End Function '----------------------------------------------
Je pose le décor : je veux faire de la communication entre un PC et un automate sous une couche TCP IP.
Pour ce faire, j'utilise l'API de windows (wsock32.dll) car je ne veux pas utiliser le contrôle winsock OCX, j'ai bien compris qu'il fallait :
1) initialiser la dll avec
Declare Function WSAStartup Lib "wsock32" _
(ByVal wVersionRequired As Integer, _
wsData As WSA_DATA) As Long
2) créer le socket avec
Declare Function Socket Lib "wsock32.dll" Alias "socket" _
(ByVal afinet As Integer, _
ByVal socktype As Integer, _
ByVal protocol As Integer) As Long
3) connecter le socket avec
Declare Function connect Lib "wsock32" _
(ByVal sock As Long, _
name As SOCK_ADDR, _
ByVal namelen As Integer) As Long
4) Envoyer un message sur le pc distant avec
Declare Function send Lib "wsock32" _
(ByVal sock As Long, _
buffer As Any, _
ByVal length As Long, _
ByVal flags As Long) As Long
Mais c'est maintenant que ça se complique, car avec le "client" crée ci dessus, je voudrais créer un évènement lors d'une réception d'un message par le serveur sur lequel je suis connecté.
Je crois avoir compris (mais là, je suis moins sur) que :
1) on peut analyser les évènemtns qui affectent un socket avec :
Declare Function WSAAsyncSelect Lib "wsock32.dll" _
(ByVal sock As Long, _
ByVal hwnd As Long, _
ByVal wMsg As Integer, _
ByVal lEvent As Long) As Integer
mais je ne sais pas trop m'en servir, à cause de hwnd.
2) on lit le message du socket reçu avec :
Declare Function recv Lib "wsock32" _
(ByVal sock As Long, _
buffer As Any, _
ByVal length As Long, _
ByVal flags As Long) As Long
Mon problème est donc le suivant :
comment avoir un évènement (du type "Data_arrival" du contrôle winsock) qui me réveille afin que je puisse utiliser ma fonction recv pour lire dans mon socket.
Merci pour le Share ;)
Je suis automaticien et pas informaticien, soyez indulgent ;)
moi je voudrai savoir si on peut se connecter a un pc distant avec winsock , entre autre par le netbios port 139
??
merci d avance
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.