Soyez le premier à donner votre avis sur cette source.
Vue 23 568 fois - Téléchargée 2 229 fois
'========================================== ' MODULE PING & DNS '******************* ' 'Par Proger ' mai 2002 ' révision aout 2003 ' protocole ICMP sur IPv4 ' 'Module permettant de faire des ping et des nslookup ! 'Module totalement autonome. 'source : basé à l'origine sur une idée de c2i DefLng A-Z Option Explicit 'Déclaration pour créer un paquet ICMP d'echo Private Type ip_option_information 'structure envoyé TTL As Integer 'TimeToLive, nombre de saut d'hôtes Tos As Byte 'Type de service Flags As Byte 'nb flag OptionsSize As Byte 'Taille en byte des datas OptionsData As Long 'Pointeur vers des datas End Type Private Type icmp_echo_reply 'structure en réponse Address As Long 'Retourne l'adresse Status As Long 'Retourne IP_STATUS RoundTripTime As Long 'RTT en ms DataSize As Integer 'Retourne la taille des données Reserved As Integer 'Reservé à une utilisation système... DataPointer As Long 'Pointeur vers le buffer retournée Options As ip_option_information 'option de retour Data As String * 10000 'buffer : en cas d'erreur 11001, l'agrandir 'note : le buffer contient les données type string qui ont été envoyé pour faire l'echo, 'c'est-à-dire "PINGECHOICMPTEST" si un ping est envoyé avec EasyPing() End Type 'API de icmp.dll utilisé Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long Private Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, ByVal DestinationAddress As Long, ByVal RequestData As String, ByVal RequestSize As Integer, RequestOptions As ip_option_information, ReplyBuffer As icmp_echo_reply, ByVal ReplySize As Long, ByVal Timeout As Long) As Long 'Déclarations pour ouvrir un socket, permettant l'envoie de l'echo Private Const WSADESCRIPTION_LEN = 256 Private Const WSASYSSTATUS_LEN = 256 Private Const WSADESCRIPTION_LEN_1 = WSADESCRIPTION_LEN + 1 Private Const WSASYSSTATUS_LEN_1 = WSASYSSTATUS_LEN + 1 Private Const SOCKET_ERROR = -1 Private Type tagWSAData wVersion As Integer wHighVersion As Integer szDescription As String * WSADESCRIPTION_LEN_1 szSystemStatus As String * WSASYSSTATUS_LEN_1 iMaxSockets As Integer iMaxUdpDg As Integer lpVendorInfo As String * 200 End Type Private Declare Function WSAStartup Lib "WSOCK32" (ByVal wVersionRequested As Integer, lpWSADATA As tagWSAData) As Integer Private Declare Function WSACleanup Lib "WSOCK32" () As Integer 'Déclaration pour convertir un nom de domaine en adresse IP Private Type HOSTENT hName As Long 'pointeur vers le premier nom de domaine de la machine (s'il y en a plusieurs rattaché) ~FQDN hAliases As Long 'pointeurs vers les autres noms de domaine hAddrType As Integer 'type d'adresse retournée hLen As Integer 'longueur de l'adresse retournée hAddrList As Long 'pointeur vers l'adresse End Type Private Declare Function gethostbyname Lib "WSOCK32" (ByVal szHost As String) As Long Private Declare Function gethostbyaddr Lib "WSOCK32" (haddr As Long, ByVal hnlen As Long, ByVal addrtype As Long) As Long Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long) Public autrIP(25) As Long 'liste interne des IP possible d'un hôte Public autrIPCnt As Long 'Déclarations pour conversion IP 32bits <> strings Private Declare Function inet_ntoa Lib "wsock32.dll" (ByVal inn As Long) As Long Private Declare Function inet_addr Lib "wsock32.dll" (ByVal cp As String) As Long Private Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Any) As Long '========================================== ' FONCTIONS DE CONVERSION IP$ <> IP <> DNS '========================================== Function GetIPofHost(NomH As String) As Long 'GetIPofHost renvoie l'adresse IP type Long IPv4 d'une machine 'paramètre : 'NomH : nom DNS de la machine, exemple : www.google.com Dim exeAPI As Long, i Dim HostInfo As HOSTENT Dim IPv4Adr As Long Dim SockStart As Long Dim SockInf As tagWSAData SockStart = WSAStartup(&H101, SockInf) 'ouvre un socket exeAPI = gethostbyname(NomH) 'recupère le pointeur vers un HOSTENT SockStart = WSACleanup() 'ferme le socket If exeAPI > 0 Then 'pour récupérer des valeurs dont on ne connais que le pointeur, on utilise 'RtlMoveMemory RtlMoveMemory HostInfo, exeAPI, ByVal (LenB(HostInfo)) RtlMoveMemory exeAPI, ByVal HostInfo.hAddrList, 4 RtlMoveMemory IPv4Adr, ByVal exeAPI, HostInfo.hLen GetIPofHost = IPv4Adr autrIP(0) = IPv4Adr For i = 1 To 25 'on cherche jusqu'a 25 autres IP pour la même machine RtlMoveMemory exeAPI, ByVal HostInfo.hAddrList + (i * 4), 4 If exeAPI <> 0 Then RtlMoveMemory IPv4Adr, ByVal exeAPI, HostInfo.hLen autrIP(i) = IPv4Adr Else autrIPCnt = i Exit For End If Next i Else 'erreur : l'hôte n'a pas d'IP. GetIPofHost = 0 End If End Function Function GetHostofIP(IPAdr As Long) As String 'GetIPofHost renvoie le premier nom DNS d'une machine dont on connais l'IP 'paramètre : 'IPAdr : adresse IP de la machine, type Long IPv4 Dim exeAPI As Long Dim HostInfo As HOSTENT Dim TmpNm As String * 255 'tampon reçevant le nom de domaine Dim SockStart As Long Dim SockInf As tagWSAData SockStart = WSAStartup(&H101, SockInf) 'ouvre un socket exeAPI = gethostbyaddr(IPAdr, Len(IPAdr), 2) 'récupère le pointeur vers un HOSTENT SockStart = WSACleanup() 'ferme le socket If exeAPI <> 0 Then RtlMoveMemory HostInfo, exeAPI, ByVal (LenB(HostInfo)) RtlMoveMemory ByVal TmpNm, HostInfo.hName, 255 'le nom de domaine se termine par un &H00&, mais à cause que l'on alloue 255 octets, il y a 'plein de vide, donc cela nécessite deux traitement. If InStr(1, TmpNm, Chr$(0)) > 0 Then TmpNm = Left$(TmpNm, InStr(1, TmpNm, Chr$(0))) GetHostofIP = Trim$(TmpNm) Else 'erreur : l'IP n'a pas de nom DNS GetHostofIP = "" End If End Function Function GetIPbinaryVal(ByVal IPAdr As String) As Long 'GetIpbinaryVal converti une adresse IP type string (a.b.c.d) en type Long 32-bits IPv4 'API Powa :) GetIPbinaryVal = inet_addr(IPAdr) End Function Function GetIPstringVal(IPlng As Long) As String 'GetIPstringVal renvoie une valeur string "a.b.c.d" a partir d'une valeur IP Long 32-bits IPv4 Dim lpStr As Long, Strl As Long, BufStr As String * 32 lpStr = inet_ntoa(IPlng) If lpStr = 0 Then GetIPstringVal = "255.255.255.255" Else Strl = lstrlenA(lpStr) If Strl > 32 Then Strl = 32 RtlMoveMemory ByVal BufStr, lpStr, Strl GetIPstringVal = Left$(BufStr, InStr(1, BufStr, Chr$(0)) - 1) End If End Function Function GetIPofCible(Cible As String) As Long 'Fonction renvoyant l'adresse IP de la cible, peu importe si la Cible est une IP ou un nom de domaine 'paramètre : 'Cible : nom de domaine ou adresse IP 'donnée retournée : 'GetIPofCible : renvoie la valeur Long IPv4 de l'IP de la cible Dim TmIP As Long 'PS : 16 octets car Len("xxx.xxx.xxx.xxx") = 15 If Len(Cible) < 16 Then TmIP = GetIPbinaryVal(Cible) If TmIP <= 0 Then TmIP = GetIPofHost(Cible) End If Else TmIP = GetIPofHost(Cible) End If GetIPofCible = TmIP End Function '=========================== ' FONCTION ENVOYANT LE PING '=========================== Function GetEcho(AdrIP As Long, RTT As Long, TTL As Long, DtSend As String, ByRef PingStat As icmp_echo_reply) As Long 'GetEcho : envoie un Ping et le récupère 'paramètres : 'AdrIP : adresse IP Type Long IPv4 de la destination 'RTT : durée en millisecondes du temps d'attente de l'echo, max 32767 'TTL : nombre de saut d'hôtes à faire 'DtSend : chaine de caractère qui sera envoyé dans le paquet ICMP 'données retournées : 'GetEcho : valeur en milliseconde du trajet, -1 si timeout, -2 si problème de socket 'PingStat : type icmp_echo_reply, pour gérer le resultat dans un autre sub Dim hICMP As Long Dim exeAPI As Long Dim PingSet As ip_option_information Dim PingGet As icmp_echo_reply Dim pWsaData As tagWSAData Dim SockState As Long 'définition du TTL du ping PingSet.TTL = TTL 'anti-erreur : traitement du RTT RTT = Abs(RTT) If RTT > 32767 Then RTT = 32767 'création d'un socket SockState = WSAStartup(&H101, pWsaData) If SockState = SOCKET_ERROR Then 'en cas d'erreur de création du socket, quitter GetEcho = -2 Exit Function End If 'ouvre un handle ICMP hICMP = IcmpCreateFile() 'envoie d'un paquet ICMP d'echo - et réception par la même occasion exeAPI = IcmpSendEcho(hICMP, AdrIP, DtSend, Len(DtSend), PingSet, PingGet, Len(PingGet), RTT) PingStat = PingGet 'ferme le handle ICMP exeAPI = IcmpCloseHandle(hICMP) 'ferme le socket SockState = WSACleanup() End Function '============================= ' FONCTION DE GESTION DU PING '============================= Function GesPing(ByRef PingEcho As icmp_echo_reply, AdrRet As Long) As Long 'Fonction de gestion du résultat du ping 'paramètre : 'PingEcho : un pointeur vers une variable de type icmp_echo_reply, résultat d'un ping 'données retournées : 'GesPing : durée en millisecondes du ping, ou -1 en cas de timeout, ou -2 en cas de problème de ' paramètres (genre ttl=0), -3 en cas de taille de tampon trop grosse. 'AdrRet : en cas de TTL expiré, renvoi l'adresse de l'hôte atteint, sinon 0 'gestion du retour (ajouté dans la màj du 24 mai 2002) 'attention, la plupart des messages ne concerne pas l'ICMP echo Select Case PingEcho.Status Case 0 'ip réalisé avec succès GesPing = PingEcho.RoundTripTime AdrRet = 0 Case 11001 'buffer de retour trop petit - erreur dû à VB n'autorisant pas un tampon de plus de 10000 octets GesPing = -3 Case 11002 'destination inatteignable Case 11003 'hôte inatteignable Case 11004 'protocole inaccessible Case 11005 'port inaccessible Case 11006 'pas de ressources Case 11007 'mauvais paramètres - vérifer le TTL GesPing = -2 Case 11008 'problème matériel Case 11009 'paquet trop gros Case 11010 'timeout GesPing = -1 AdrRet = 0 Case 11011 'mauvaise requête Case 11012 'mauvaise route Case 11013 'temps de transit expiré (ttl trop petit) GesPing = PingEcho.RoundTripTime AdrRet = PingEcho.Address Case 11014 'ttl trop petit pour le réassemblement Case 11015 'problème de paramètre Case 11016 'source arreté Case 11017 'trop d'options Case 11018 'mauvaise destination Case 11019 'adresse supprimé Case 11020 'changement de MTU nécessaire Case 11021 'changement MTU effectué Case 11022 'déchargement de la mémoire Case 11023 'adresse rajouté Case 11050 'defaillance générale Case 11255 'en suspend End Select End Function '========================================== ' FONCTIONS SIMPLIFIE ou PRE-CODE ' (vous pouvez les supprimer de ce module) '========================================== Function EasyPing(ByVal Adresse As String) As String 'Fonction d'envoie de ping simplifié. 'paramètre : 'Adresse : adresse IP de type "a.b.c.d" ou nom de domaine de la cible 'donnée retournée : 'StandardPing : renvoie une chaine de caractère avec soit "n ms" soit "Timeout" Dim Rping As icmp_echo_reply Dim BadAdr As Long Dim Tp As Long Tp = GetEcho(GetIPofCible(Adresse), 2000, 128, "PINGECHOICMPTEST", Rping) Tp = GesPing(Rping, BadAdr) Select Case Tp Case -3 EasyPing = "SZErr" Case -2 EasyPing = "Err" Case -1 EasyPing = "Timeout" Case Else EasyPing = Tp & " ms" End Select End Function Function IncrTracert(ByVal Adresse As String, ByVal TTL As Long, ByRef HoteRTT As Long) As String 'Fonction à utiliser pour faire un traceroute vers la machine Adresse 'paramètre : 'Adresse : adresse IP de type "a.b.c.d" ou nom de domaine de la cible à traçer 'TTL : valeur à incrémenter a partir de 0 jusqu'a ce que IncrTracert = Adresse 'données retournées : 'IncrTracert : adresse IP de l'hôte numéro "TTL" 'HoteRTT : durée, en millisecondes, de l'echo vers cet hôte; non formaté! Dim Ptmp As icmp_echo_reply Dim HotAddr As Long Dim EchoMS As Long EchoMS = GetEcho(GetIPofCible(Adresse), 2500, TTL, "PINGECHOICMPTEST", Ptmp) EchoMS = GesPing(Ptmp, HotAddr) If HotAddr <> 0 Then IncrTracert = GetIPstringVal(HotAddr) Else IncrTracert = AlwaysGetIP(Adresse) End If HoteRTT = EchoMS End Function Function GetNbHope(Adresse As String) As Long 'Fonction renvoyant le nombre de "saut" (ou de machines) nécessaire pour aller jusqu'à la cible 'Code de Proger - code à usage déconseillé (gaspillage de temps pour faire un traceroute interne) 'paramètre : 'Adresse : adresse IP de type "a.b.c.d" de la cible 'donnée retournée : 'EasyNbHope : nombre de saut Dim TPng As icmp_echo_reply Dim HopeAddr As Long Dim HopeEcho As Long Dim i As Long For i = 0 To 255 DoEvents 'permet à votre machine de "souffler un peu" entre chaque recherche de saut 'HopeAddr = IncrTracert(Adresse, i, HopeEcho) HopeEcho = GetEcho(GetIPbinaryVal(Adresse), 10&, i, "PINGECHO", TPng) HopeEcho = GesPing(TPng, HopeAddr) If HopeAddr = Adresse Then Exit For Next i GetNbHope = i End Function Function AlwaysGetDNS(ByVal Nval As String) As String 'Fonction renvoyant toujours le nom de domaine, peu importe si le paramètre d'entrée ' est un nom de domaine ou une IP AlwaysGetDNS = GetHostofIP(GetIPofCible(Nval)) End Function Function AlwaysGetIP(ByVal Nval As String) As String 'Fonction renvoyant toujours l'IP de la machine, peu importe si le paramètre d'entrée ' est un nom de domaine ou une IP AlwaysGetIP = GetIPstringVal(GetIPofCible(Nval)) End Function Sub ExempleDeTraceRoute(ByVal LaCible As String, ByVal MaxSaut As Long, OutListe As ListBox) 'DEMONSTRATION : réalise un traceroute vers la machine LaCible (défini avec son ip ou dnsname) 'Code de Proger - usage déconseillé (la présentation dans une ListBox, c'est pas top) 'Paramètre : 'LaCible : adresse IP de type "a.b.c.d" ou nom de domaine de la cible à traçer 'MaxSaut : nombre d'hôtes qui seront parcourus avant d'abandonner le traçage. 30 est une bonne valeur. 'OutListe : nom d'un objet ListBox (liste déroulante standard) de sortie Dim TraceChaine As String Dim OutPchaine As String Dim RTTofSaut As Long Dim RTTstr As String Dim i As Long OutListe.Clear OutListe.FontName = "Courier New" 'police à chasse fixe For i = 1 To MaxSaut OutPchaine = IncrTracert(LaCible, i, RTTofSaut) Select Case RTTofSaut 'formatage en string de la durée de l'echo Case -3 RTTstr = "SZErr" Case -2 RTTstr = "Err!" Case -1 RTTstr = "Timeout" Case Else RTTstr = RTTofSaut & " ms" End Select 'formatage de la chaine de sortie du traçage. La fonction String() permet de générer des caractères ' espace (" ") pour simuler des colonnes dans la liste. TraceChaine = i & String$(4 - Len(CStr(i)), " ") & RTTstr & String$(8 - Len(RTTstr), " ") & OutPchaine & String$(16 - Len(OutPchaine), " ") & AlwaysGetDNS(OutPchaine) OutListe.AddItem TraceChaine OutListe.ListIndex = i - 1 'avance du curseur DoEvents 'laisse windows afficher le contenu de la liste If GetIPbinaryVal(OutPchaine) = GetIPofCible(LaCible) Then Exit For 'permet de savoir si on a atteint la cible Next i End Sub Function PingDef(Adresse As String, SzPing As Long, Optional sTTL As Long) As String 'Fonction ajouté dans la mise à jour du 24 mai 2002 'Ping simplifié, avec comme paramètre obligatoire la taille du "tampon" 'et comme paramètre optionnel le TTL de l'echo Dim TmpPng As icmp_echo_reply Dim BadAdr As Long Dim Tp As Long If sTTL <= 0 Then sTTL = 128 Tp = GetEcho(GetIPofCible(Adresse), 2000, sTTL, String$(SzPing, "A"), TmpPng) Tp = GesPing(TmpPng, BadAdr) Select Case Tp Case -3 PingDef = "SZErr" Case -2 PingDef = "Err" Case -1 PingDef = "Timeout" Case Else PingDef = Tp & " ms" End Select End Function
J'ai recherché sur le Net des informations sur une solution de remplacement, mais personne ne répond.
Si vous avez une nouvelle méthode, je suis preneur.
GOWAP
Good job Proger !
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.