Dos ping - shell dos avec un usercontrol

Télécharger le projet
Commenter

Description

Bon, ben j'ai vu qu'il y en a plein d'autres déjà... Mais c'est pas grave...
En gros voilà :
j'ai fait un UserControl (donc adaptable à toute feuille) qui se charge d'exécuter ping avec DOS.
J'enregistre la sortie DOS dans un fichier genre c:\ping9954
Ensuite j'ouvre ce fichier et je l'analyse
et je récupère le plus important
Ca permet aussi de trouver la vraie DNS d'un serveur (genre www.google.fr donne www.google.akadns.net) et son IP.
On peut aussi faire un test d'écho plus important (100 tests) ou répétitif

Source / Exemple : 


'Fonction Ping :

Private Sub ping(Optional nPing As Integer)
On Error Resume Next

If nPing <= 1 Then nPing = 1

Dim stradr As String
If optIP.Value Then
    stradr = ip(0) & "." & ip(1) & "." & ip(2) & "." & ip(3)
Else
    stradr = dns.Text
End If
Dim path As String
path = "c:\ping" & Int(Rnd() * 10000)

    Shell "cmd /C ping " & stradr & " -n " & nPing & " > " & path, vbHide
    info.Caption = "Waiting " & (nPing + 2) & " sec for results..." & vbCrLf
    Wait (nPing + 2) * 1000 'attrendre 4sec les résultats
    info = "Analysing results..."

'test de réussite ou d'échec :
Dim Result As String
Result = searchParam(path, "sur", False, " ", " ")
If Result = "" Then GoTo erreur

Moy = Val(searchParam(path, "Moyenne", False, "= ", "ms"))
Min = Val(searchParam(path, "Minimum", False, "= ", "ms"))
Max = Val(searchParam(path, "Maximum", False, "= ", "ms"))
'bon, d'accord, c'est un peu redondant, on utilise 4 fois searchParam qui ouvre 4 fois le fichier, mais au moins c rapide à coder et suffisament efficace...

results.Caption = "Résultats sur " & nPing & " tests d'échos (en ms) :" & vbCrLf & Min & " < " & Moy & " < " & Max

If optDNS.Value Then
    'récupère l'IP
    realDNS = searchParam(path, "sur", False, " ", " ")
    dns.Text = realDNS
    realIP = searchParam(path, "[", False, "", "]")
    
    Dim ch As String, j As Integer, no As Integer
    j = 0
    no = 0
    ip(0).Text = "": ip(1).Text = "": ip(2).Text = "": ip(3).Text = ""
    Do Until j >= Len(realIP)
        j = j + 1
        ch = Mid(realIP, j, 1)
        If ch <> "." Then
            ip(no).Text = ip(no).Text & ch
        Else
            no = no + 1
        End If
    Loop
End If

info = "Echo test finished at " & Time

Kill path 'supprime fichier path
GoTo fin
erreur:
    info = "Echec de ping : aucun serveur n'a été trouvé"
    'info, c'est un label
fin:
End Sub

'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

'Fonction searchParam
'elle ouvre et analyse le fichier...

Public Function searchParam(filePath As String, paramTitle As String, Optional multi As Boolean, Optional sepStr As String, Optional lastCar1 As String, Optional lastCar2 As String) As String
    'sepStr : la chaine présentant la valeur du parametre cherché. ex:
    'Adresse IP . . . . . . . . : 127.0.0.1
    'ici, sepStr = ": "
    
    'lastCar1 : le caractère suivant la valeur du parametre. ex:
    'Adresse IP . . . . . . . . : 127.0.0.1
    'ici, lastStr1 = chr(10) et lastStr2 = chr(13) (===> vbcrlf)
    
    'multi : défini si il faut chercher plusieurs parametres ou un seul
    
    If lastCar1 = "" Then lastCar1 = Chr(10)
    If lastCar2 = "" Then lastCar2 = Chr(13)
    lastCar1 = Left(lastCar1, 1)
    lastCar2 = Left(lastCar2, 1) 'on ne garde que la premiere lettre
    
    If paramTitle = "" Then GoTo fin
        
    Dim noFile As Integer, intNoEssai As Integer, intNoEssai2 As Integer
    noFile = FreeFile()
    
testExists:
        Wait 250
        intNoEssai = intNoEssai + 1
        If intNoEssai > 80 Then GoTo fin 'attend max. 20 secondes (20 = 80 * 0.25)
    If Dir$(filePath) = "" Then GoTo testExists
    
    Open filePath For Input As noFile
    
    If LOF(noFile) = 0 Then
        intNoEssai2 = intNoEssai2 + 1
        Close noFile
        Wait 1000
        If intNoEssai > 60 Then GoTo fin 'attend max. 60 secondes
        GoTo testExists
    End If
    
    Do Until EOF(noFile)
    
        Dim cache As String
        Dim Octet As String
        
        'cherche le titre du param
        Do While cache <> paramTitle
            'recherche : "Adresse IP"
            If EOF(noFile) Then GoTo endLoop
            Octet = Input(1, noFile)
            cache = cache & Octet
            If Len(cache) > Len(paramTitle) Then cache = Right(cache, Len(paramTitle))
        Loop
        cache = ""
        Octet = ""
        
        'saute le sepStr
        If sepStr <> "" Then
            Do While cache <> sepStr
                If EOF(noFile) Then GoTo endLoop
                Octet = Input(1, noFile)
                cache = cache & Octet
                If Len(cache) > Len(sepStr) Then cache = Right(cache, Len(sepStr))
            Loop
        End If
        cache = ""
        Octet = ""
        
        'récupère la valeur
        Do While Octet <> lastCar1 And Octet <> lastCar2
            If EOF(noFile) Then GoTo endLoop
            Octet = Input(1, noFile)
            If Octet <> lastCar1 And Octet <> lastCar2 Then _
                cache = cache & Octet
        Loop
        
        If searchParam = "" Then
            searchParam = searchParam & cache
        Else
            searchParam = searchParam & vbCrLf & cache
        End If
        
        If Not multi Then GoTo fin
        
endLoop:
    Loop
    
fin:
    Close noFile
End Function

'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

'Un petit plus : passer d'une case ip à une autre (la suivante) en enfonçant le bouton "."
'Ceci pour taper facilement une ip (127. >> change de case 0. >>change 0. >>...)

Private Sub ip_KeyPress(Index As Integer, KeyAscii As Integer)
    If KeyAscii < 48 Or KeyAscii > 57 Then 'pas des nombres
        If KeyAscii = 46 And Index <= 3 Then 'point
            ip(Index + 1).SetFocus
            ip(Index + 1).Text = ""
        End If
        If KeyAscii <> 8 Then _
            KeyAscii = 0
    End If
End Sub

Conclusion :


N'hésitez évidemment pas à envoyer remarques, bugs ou autres
Vous pouvez aussi ne garder que la fonction ping et la fonction searchParam pour faire un prog tout bête.

Bon à part ça, je sais... mon prog est pas génial, paske j'utilise un Shell "cmd /C ping machintruc > monfichier" et qu'ainsi ça fonctionne que sous winXP NT 2000... mais bon

Allez codez bien !
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

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.

Du même auteur (Helkanen)