Ping vb sous vb (maj)

Soyez le premier à donner votre avis sur cette source.

Vue 11 469 fois - Téléchargée 1 085 fois

Description

Rien à faire seulement modifier pour obtenir ce que vous voulez :-)

Source / Exemple :


'*******************************************************************
'   PingVB
'
'   Cette application sert a faire un ping vb en utilisant
'    ICMP.DLL
'
'
'*******************************************************************
Private Const IP_STATUS_BASE = 11000

Private Const IP_SUCCESS = 0
Private Const IP_BUF_TOO_SMALL = (11000 + 1)
Private Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
Private Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
Private Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
Private Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
Private Const IP_NO_RESOURCES = (11000 + 6)
Private Const IP_BAD_OPTION = (11000 + 7)
Private Const IP_HW_ERROR = (11000 + 8)
Private Const IP_PACKET_TOO_BIG = (11000 + 9)
Private Const IP_REQ_TIMED_OUT = (11000 + 10)
Private Const IP_BAD_REQ = (11000 + 11)
Private Const IP_BAD_ROUTE = (11000 + 12)
Private Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
Private Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
Private Const IP_PARAM_PROBLEM = (11000 + 15)
Private Const IP_SOURCE_QUENCH = (11000 + 16)
Private Const IP_OPTION_TOO_BIG = (11000 + 17)
Private Const IP_BAD_DESTINATION = (11000 + 18)
'

Private Const IP_ADDR_DELETED = (11000 + 19)
Private Const IP_SPEC_MTU_CHANGE = (11000 + 20)
Private Const IP_MTU_CHANGE = (11000 + 21)
Private Const IP_UNLOAD = (11000 + 22)
Private Const IP_ADDR_ADDED = (11000 + 23)

Private Const IP_GENERAL_FAILURE = (11000 + 50)
Private Const MAX_IP_STATUS = 11000 + 50
Private Const IP_PENDING = (11000 + 255)

Private Type ip_option_information
    Ttl             As Byte     'duree de vie
    Tos             As Byte     'Type de service
    Flags           As Byte     'nb flag
    OptionsSize     As Byte     'Taille en byte des dats
    OptionsData     As Long     'Pointer vers options data
End Type

'   structure retourné pas le ping pour donner le statur ou les error information
Private Type icmp_echo_reply
    Address         As Long             'Retourne l'@
    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èem
    DataPointer     As Long             'Pointeur vers la donné retourné
    Options         As ip_option_information    'option de retour
    Data            As String * 250
End Type

'   fonction 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

Private Const PING_TIMEOUT = 200        ' nb seconde a attendre

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

Private Sub btnExit_Click()
    End
End Sub

Private Sub btnPing_Click()

    Dim hFile       As Long
    Dim lRet        As Long
    Dim lIPAddress  As Long
    Dim strMessage  As String
    Dim pOptions    As ip_option_information
    Dim pReturn     As icmp_echo_reply
    Dim iVal        As Integer
    Dim lPingRet    As Long
    Dim pWsaData    As tagWSAData
    
    strMessage = "Echo cette chaine de donnée"
    
    iVal = WSAStartup(&H101, pWsaData)
    
    'Convertit l'adresse ip en long
    lIPAddress = ConvertIPAddressToLong(txIPAddress)
    
    '   ouvre un fichier pour le ping
    hFile = IcmpCreateFile()
    
    '   met la duréee de vie du ping
    pOptions.Ttl = Val(txTTL)
    
    'Fonction qui ping
    lRet = IcmpSendEcho(hFile, _
                        lIPAddress, _
                        strMessage, _
                        Len(strMessage), _
                        pOptions, _
                        pReturn, _
                        Len(pReturn), _
                        PING_TIMEOUT)

    If lRet = 0 Then
        'Error buffer
        lbReturn.AddItem "Erreur ping " & pReturn.Status
        lbReturn.ListIndex = lbReturn.ListCount - 1
    Else
        'Ping effectué status doit = 0
        If pReturn.Status <> 0 Then
            lbReturn.AddItem "Erreurr -> Ping non terminé = " & pReturn.Status
            lbReturn.ListIndex = lbReturn.ListCount - 1
        Else
            lbReturn.AddItem "Réussite => Temps -> " & pReturn.RoundTripTime & "ms."
            lbReturn.ListIndex = lbReturn.ListCount - 1
        End If
    End If
                        
    '   ferme le file
    lRet = IcmpCloseHandle(hFile)
    
    iVal = WSACleanup()
    
End Sub

'
'   ConvertIPAddressToLong
'
'   Convertit l'adresse ip avec ses points en long

'   on a "a.b.c.d" et nous voulons Val(&Hddccbbaa).
'

Function ConvertIPAddressToLong(strAddress As String) As Long

    Dim strTemp             As String
    Dim lAddress            As Long
    Dim iValCount           As Integer
    Dim lDotValues(1 To 4)  As String
    
 
    strTemp = strAddress
    iValCount = 0
    
    ' tant qu'il y a des points
    While InStr(strTemp, ".") > 0
        iValCount = iValCount + 1   'ben compte
        lDotValues(iValCount) = Mid(strTemp, 1, InStr(strTemp, ".") - 1)    ' vire le point et convertit
        strTemp = Mid(strTemp, InStr(strTemp, ".") + 1)
        Wend
        

    iValCount = iValCount + 1
    lDotValues(iValCount) = strTemp
    
   'Si il n'y a pas quatre element ben le ping marchera po alors il s'arrete
    If iValCount <> 4 Then
        ConvertIPAddressToLong = 0
        Exit Function
        End If
        
   'hex les 4 valeurs
    lAddress = Val("&H" & Right("00" & Hex(lDotValues(4)), 2) & _
                Right("00" & Hex(lDotValues(3)), 2) & _
                Right("00" & Hex(lDotValues(2)), 2) & _
                Right("00" & Hex(lDotValues(1)), 2))
                
    '  valeur de retour
    ConvertIPAddressToLong = lAddress
    
End Function

Conclusion :


Ben rien jamais eu de probleme avec ben si vous en avez un mailez moi .

::Je vous met un zip un an après !!:: pardonnez moi lol

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

Messages postés
6
Date d'inscription
vendredi 29 avril 2005
Statut
Membre
Dernière intervention
19 avril 2007

Merci pour ce code ca m'a permis de gagner du temps.
C'est nikel. Juste une petite chose de rien du tout, il y a le code pour quitter mais pas le boutton enfin c'est pas grand chose.
Messages postés
63
Date d'inscription
jeudi 4 décembre 2003
Statut
Membre
Dernière intervention
23 avril 2013

Code Interessant, dommage que la fonction ne retourne pas le nom de l'hote, il est parfois utile de pinguer sur le nom.
Concernant la conversion d'adresse en entier long, il est possible de faire plus simple et plus rapide la fonction Split étant très performante:
'
Function ConvertIPAddressToLong(strAddress As String) As Long
Dim Tableau() As String
'
Tableau = Split(strAddress, ".") 'La fonction Split Renvoie un tableau de base zéro à une dimension contenant le nombre de sous-chaines déterminées par le caractère de séparation (ici le point)
strAddress = "&H" & Format(Hex(Tableau(3)), "00") & _
Format(Hex(Tableau(2)), "00") & _
Format(Hex(Tableau(1)), "00") & _
Format(Hex(Tableau(0)), "00")
ConvertIPAddressToLong = Val(strAddress)
End Function

Idem pour le test de validité de l'adresse IP
Private Function IpValid(IpAdress As String) As Boolean
Dim Tableau() As String
Dim Compteur As Integer
'
On Error Resume Next
Tableau() = Split(Trim(IpAdress), ".")
If UBound(Tableau) = 3 Then
IpValid = True
For Compteur = 0 To 3
If Compteur < 3 And Val(Tableau(Compteur)) <= 255 And Val(Tableau(Compteur)) > -1 Then
IpValid = True
ElseIf Compteur = 3 And Val(Tableau(Compteur)) < 255 And Val(Tableau(Compteur)) > -1 Then
IpValid = True
Else
IpValid = False
Exit For
End If
Next Compteur
Else
IpValid = False
Exit Function
End If
End Function
Messages postés
2
Date d'inscription
mercredi 10 janvier 2001
Statut
Membre
Dernière intervention
1 décembre 2002

au fait presseb=TheSaib
Messages postés
2
Date d'inscription
mercredi 10 janvier 2001
Statut
Membre
Dernière intervention
1 décembre 2002

et puis je vous ai mis un ZIP j'ai retrouvé mon mot de passe lol (un an après)
Messages postés
2368
Date d'inscription
mardi 17 avril 2001
Statut
Modérateur
Dernière intervention
26 décembre 2007
15
'La liste des erreurs pouvant etre retourné !

11001 Buffer Too Small
11002 Destination Net Unreachable
11003 Destination Host Unreachable
11004 Destination Protocol Unreachable
11005 Destination Port Unreachable
11006 No Resources
11007 Bad Option
11008 Hardware Error
11009 Packet Too Big
11010 Request Timed Out
11011 Bad Request
11012 Bad Route
11013 TimeToLive Expired Transit
11014 TimeToLive Expired Reassembly
11015 Parameter Problem
11016 Source Quench
11017 Option Too Big
11018 Bad Destination
11032 Negotiating IPSEC
11050 General Failure
Afficher les 17 commentaires

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.