Macro qui ping des serveurs lente

**kevin254kl** · 16/11/2016, 10h22

Bonjour à tous j'ai une maccro qui ping les serveur entrer dans une feuille excel et me renvoi la disponibilité de ceux-ci.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
   Function GetPingResult(Host)
 
   Dim objPing As Object
   Dim objStatus As Object
   Dim Result As String
 
   Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
       ExecQuery("Select * from Win32_PingStatus Where Address = '" & Host & "'")
 
   For Each objStatus In objPing
      Select Case objStatus.StatusCode
         Case 0: strResult = "Connected"
         Case 11001: strResult = "Buffer too small"
         Case 11002: strResult = "Destination net unreachable"
         Case 11003: strResult = "Destination host unreachable"
         Case 11004: strResult = "Destination protocol unreachable"
         Case 11005: strResult = "Destination port unreachable"
         Case 11006: strResult = "No resources"
         Case 11007: strResult = "Bad option"
         Case 11008: strResult = "Hardware error"
         Case 11009: strResult = "Packet too big"
         Case 11010: strResult = "Request timed out"
         Case 11011: strResult = "Bad request"
         Case 11012: strResult = "Bad route"
         Case 11013: strResult = "Time-To-Live (TTL) expired transit"
         Case 11014: strResult = "Time-To-Live (TTL) expired reassembly"
         Case 11015: strResult = "Parameter problem"
         Case 11016: strResult = "Source quench"
         Case 11017: strResult = "Option too big"
         Case 11018: strResult = "Bad destination"
         Case 11032: strResult = "Negotiating IPSEC"
         Case 11050: strResult = "General failure"
         Case Else: strResult = "Unknown host"
      End Select
      GetPingResult = strResult
   Next
 
   Set objPing = Nothing
 
End Function
 
Sub GetIPStatus()
 
  Dim Cell As Range
  Dim ipRng As Range
  Dim Result As String
  Dim Wks As Worksheet
 
 
Set Wks = Worksheets("PING")
 
' ip hspr
Set ipRng = Wks.Range("C2")
Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)
Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))
 
  For Each Cell In ipRng
    Result = GetPingResult(Cell)
    Cell.Offset(0, 1) = Result
      If Result = "Connected" Then
    Cell.Offset(0, 1).Interior.Color = RGB(0, 150, 0)
Else
    If Result = "Time-To-Live (TTL) expired transit" Then
        Cell.Offset(0, 1).Interior.Color = RGB(255, 153, 0)
    Else
        Cell.Offset(0, 1).Interior.Color = RGB(255, 0, 0)
    End If
End If
  Next Cell
 
' ip primaire
Set ipRng = Wks.Range("E2")
Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)
Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))
 
  For Each Cell In ipRng
    Result = GetPingResult(Cell)
    Cell.Offset(0, 1) = Result
      If Result = "Connected" Then
    Cell.Offset(0, 1).Interior.Color = RGB(0, 150, 0)
Else
    If Result = "Time-To-Live (TTL) expired transit" Then
        Cell.Offset(0, 1).Interior.Color = RGB(255, 153, 0)
    Else
        Cell.Offset(0, 1).Interior.Color = RGB(255, 0, 0)
    End If
End If
  Next Cell
 
' ip secondaire
Set ipRng = Wks.Range("G2")
Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)
Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))
 
  For Each Cell In ipRng
    Result = GetPingResult(Cell)
    Cell.Offset(0, 1) = Result
      If Result = "Connected" Then
    Cell.Offset(0, 1).Interior.Color = RGB(0, 150, 0)
Else
    If Result = "Time-To-Live (TTL) expired transit" Then
        Cell.Offset(0, 1).Interior.Color = RGB(255, 153, 0)
    Else
        Cell.Offset(0, 1).Interior.Color = RGB(255, 0, 0)
    End If
End If
  Next Cell
 
' ip switch
Set ipRng = Wks.Range("I2")
Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)
Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))
 
  For Each Cell In ipRng
    Result = GetPingResult(Cell)
    Cell.Offset(0, 1) = Result
      If Result = "Connected" Then
    Cell.Offset(0, 1).Interior.Color = RGB(0, 150, 0)
Else
    If Result = "Time-To-Live (TTL) expired transit" Then
        Cell.Offset(0, 1).Interior.Color = RGB(255, 153, 0)
    Else
        Cell.Offset(0, 1).Interior.Color = RGB(255, 0, 0)
    End If
End If
  Next Cell
 
End Sub

Comme vous pouvez le voir il y a 3 sections ip, mais le temps que cela m'est pour avoir un résultat est d'une minute je me demandais si il était possible d'optimiser ou si le temps vient des pings?

**jurassic pork** · 16/11/2016, 11h54

hello,
il faudrait que tu puisses lancer tes requêtes WMI en mode asynchrone, mais cela m'étonnerait que cela fonctionne en VBA. Le principe : tu lances la requête et tu attends un événement de fin pour effectuer le traitement (qui se trouve dans une autre procédure) suivant la requête.

Ami calmant, J.P

**joe.levrai** · 16/11/2016, 12h28

Bonjour,

du coup, ne serait-il pas possible (un coucou à Patric et Marc-L) de générer un vbs à la volée par demande de ping et de l'exécuter en tâche planifiée (qu'on détruit ensuite).

on tombe ainsi dans de l'asynchrone possible ?

**kevin254kl** · 16/11/2016, 12h59

Merci , ma question est plus simple. Si j'utilise une seul boucle cela va diminuer le temps d’exécution de la maccro de façon conséquente? si oui comment je peux couplé les trois boucles?

**jurassic pork** · 16/11/2016, 15h29

peut être avec le Excel VBA multithreading Tool voir ici

**kevin254kl** · 16/11/2016, 20h16

Merci, mais la maccro sera disponible sur un serveur donc cela veut dire que ceux qui non pas le plugin dans leur excel pour le multhreading, ne pourront pas l'utiliser?

**Marc-L** · 17/11/2016, 10h24

Envoyé par joe.levrai

ne serait-il pas possible (un coucou à Patric et Marc-L) de générer un vbs à la volée par demande de ping et de l'exécuter en tâche planifiée

Salut Joe !

En direct - sans passer en tâche planifiée - façon Let It Bee : oui et donc sans add-in …
Et puis pas obligé de forcément le générer si appel à un .vbs déjà existant …

_________________________________________________________________________________________________________
Je suis Paris, Nice, Bruxelles, Charlie, …

**joe.levrai** · 17/11/2016, 11h39

Bonjour,

je pensais que c'était le fait de le faire passer par une tâche planifiée qui générait l'asynchronicité du traitement, pas l'exécution du vbs seule.
Merci pour le tuyau, j'ai un projet dans les cartons où je comptais justement aller chercher le miel de votre "ruche"

Avec votre accord, j'en ferai peut-être un billet de blog si c'est concluant ?

**Marc-L** · 17/11/2016, 11h44

Windows étant multi-taches …

Pas de souci Joe ! Et depuis ma contribution, je me suis aperçu sur des forums étrangers d'autres ont eu la même idée …

Invité · 17/11/2016, 11h49

bonjour,
je suis moins féru dans ce qui concerne la récupération de ce genre d'information! alors jouer les candides ça me va bien!

n'y a-t-il pas une instruction dos qui ferait ça du genre?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

shell "dir c:\*.* >fichier.txt"

ainsi on parcoure le fichier et on en extrait la substantielle moelle!

**Marc-L** · 17/11/2016, 12h02

Salut Robert !

Si dans un fichier ou même directement en mémoire :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

    V = Split(CreateObject("WScript.Shell").Exec("cmd /c dir ""C:\DocXL\*.xl*"" /s/b/o-d").StdOut.ReadAll, vbCrLf)

Documentation MSDN WshShell …

Mais la présentation initiale concerne des pings d'adresses et non pas lister des fichiers …

_________________________________________________________________________________________________________

Je suis Paris, Nice, Bruxelles, Charlie, …

**jurassic pork** · 18/11/2016, 08h37

hello,
bon finalement le Excel VBA multithreading Tool n'est pas qu'un addin. On peut l'utiliser en important deux modules dans son classeur.
Voici comment procéder :
1 - Télécharger le Excel VBA multithreading Tool sur cette page . Cliquer sur le bouton vert Download et donner une adresse courriel valide dans la fenêtre qui s'ouvre pour pouvoir récupérer un lien pour le téléchargement.
2 - Dans le zip récupéré VBA-Multithreading-Tool_20141221.zip , importer dans votre classeur le module de classe Parallel.cls et le module ParallelMethods.bas.

Voici un exemple d'utilisation avec des pings asynchrones : Dans une feuille de classeur on a une colonne avec les adresses IP des machines à pinger ("D1

4") et dans la colonne à côté on affiche le résultat du ping ("E1:E4"). On va lancer les 4 pings en parallèle.
Voici le code de la procédure de lancement :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Public Sub TestAsyncPingThread()
    Dim startD As Date, endD As Date, parallelKey As String
    Dim par1, par2, par3, par4 As Parallel
    Range("E1:E5") = ""
    Set par1 = New Parallel
    Set par2 = New Parallel
    Set par3 = New Parallel
    Set par4 = New Parallel
    startD = Timer
    Call par1.ParallelAsyncInvoke("RunAsyncPing", Range("D1"), "E1")
    Call par2.ParallelAsyncInvoke("RunAsyncPing", Range("D2"), "E2")
    Call par3.ParallelAsyncInvoke("RunAsyncPing", Range("D3"), "E3")
    Call par4.ParallelAsyncInvoke("RunAsyncPing", Range("D4"), "E4")
    par1.AsyncThreadJoin
    par2.AsyncThreadJoin
    par3.AsyncThreadJoin
    par4.AsyncThreadJoin
    endD = Timer
    Range("E5") = endD - startD
End Sub

et voici la procédure de ping :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
Sub RunAsyncPing(workbookName As String, host As String, address As String)
   Dim objPing As Object
   Dim objStatus As Object
   Dim Result As String
   Dim r As Range
   Set r = Range(address)
   Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
       ExecQuery("Select * from Win32_PingStatus Where Address = '" & host & "'")
   For Each objStatus In objPing
      Select Case objStatus.StatusCode
         Case 0: strResult = "Connected"
         Case 11001: strResult = "Buffer too small"
         Case 11002: strResult = "Destination net unreachable"
         Case 11003: strResult = "Destination host unreachable"
         Case 11004: strResult = "Destination protocol unreachable"
         Case 11005: strResult = "Destination port unreachable"
         Case 11006: strResult = "No resources"
         Case 11007: strResult = "Bad option"
         Case 11008: strResult = "Hardware error"
         Case 11009: strResult = "Packet too big"
         Case 11010: strResult = "Request timed out"
         Case 11011: strResult = "Bad request"
         Case 11012: strResult = "Bad route"
         Case 11013: strResult = "Time-To-Live (TTL) expired transit"
         Case 11014: strResult = "Time-To-Live (TTL) expired reassembly"
         Case 11015: strResult = "Parameter problem"
         Case 11016: strResult = "Source quench"
         Case 11017: strResult = "Option too big"
         Case 11018: strResult = "Bad destination"
         Case 11032: strResult = "Negotiating IPSEC"
         Case 11050: strResult = "General failure"
         Case Else: strResult = "Unknown host"
      End Select
      r.Value = strResult
   Next
   Set objPing = Nothing
   Call ParallelMethods.SaveRangeToMaster(workbookName, r)
End Sub

et voici le résultat :
Nom : excelAsyncPing.gif
Affichages : 1368
Taille : 13,3 Ko

Attention il ne faut pas abuser du lancement de tâches en parallèle car cela est gourmand en ressources : une nouvelle instance d'Excel est lancée pour chaque tâche en parallèle. Bien sûr quand la tâche est terminée les ressources sont libérées.

Nom : Excel-Multithreading-Taskmanager.png
Affichages : 1257
Taille : 38,8 Ko

Nom : Excel-Multithreading-Taskmanager.png
Affichages : 1257
Taille : 38,8 Ko

EDIT : j'oubliais de préciser que j'ai fait le test avec un processeur 4 cores.

Ami calmant, J.P

**Marc-L** · 18/11/2016, 11h39

Envoyé par jurassic pork

cela est gourmand en ressources : une nouvelle instance d'Excel est lancée pour chaque tâche en parallèle.

C'est à cause de cela je préfère appeler un script vbs par tache car c'est bien moins gourmand
(j'en ai déjà lancés plus d'une centaine à la volée sans souci sur un ordinateur disposant de juste 4Go de RAM)
et donc comme Windows est multi-taches cela donne le même résultat comme dans ta visualisation …

**kevin254kl** · 18/11/2016, 13h29

Super merci de votre aide

**patricktoulon** · 18/11/2016, 22h31

re
Bonsoir
héh!! le cochon préhistorique c'est pas sérieux!!!

lancer 36 instances de l'application excel woh!! la tu me surprend!!!

Marc démontre dans sa contrib pour ses requête comment les accélérer en extériorisant la procédure dans un vbs lancé instanciée x fois simultanément

non c'est vraiment pas sérieux

j'ai un super PC j'oserais même pas lui faire j'ai pourtant un 6 cœurs avec 32 giga de ram(corsaire)

non en une environ 50 aine de ligne de code c'est bouclé sincèrement et encore c'est un brouillon
exemple dans ma feuille 1 colonne A j'ai les adresses a pinguer

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Dim fichier As String
Sub test()
    fichier = ThisWorkbook.Path & "\pingo.vbs"
    SC = """" & fichier & """ "
    createpingeur    ' creation du fichier vbs
    With CreateObject("WScript.Shell")
        For i = 1 To cells(rows.count,1).end(xlup).row
            .Run SC & Cells(i, 1).Value & " " & Cells(i, 1).Row
        Next
    End With
End Sub
 
Function createpingeur()    ' fonction de creation du fichier vbs
    code = code & "Dim objPing" & vbCrLf
    code = code & "Dim objStatus" & vbCrLf
    code = code & "Dim Result " & vbCrLf
    code = code & "Set objPing = GetObject(""winmgmts:{impersonationLevel=impersonate}""). _" & vbCrLf
    code = code & "ExecQuery (""Select * from Win32_PingStatus Where Address = '"" & wscript.arguments(0) & ""'"")" & vbCrLf
    code = code & "For Each objStatus In objPing" & vbCrLf
    code = code & "Select Case objStatus.StatusCode " & vbCrLf
    code = code & "Case 0: strResult = ""Connected""" & vbCrLf
    code = code & "Case 11001: strResult = ""Buffer too small""" & vbCrLf
    code = code & "Case 11002: strResult = ""Destination net unreachable""" & vbCrLf
    code = code & "Case 11003: strResult = ""Destination host unreachable""" & vbCrLf
    code = code & "Case 11004: strResult = ""Destination protocol unreachable""" & vbCrLf
    code = code & "Case 11005: strResult = ""Destination port unreachable""" & vbCrLf
    code = code & "Case 11006: strResult = ""No resources""" & vbCrLf
    code = code & "Case 11007: strResult = ""Bad option""" & vbCrLf
    code = code & "Case 11008: strResult = ""Hardware error""" & vbCrLf
    code = code & "Case 11009: strResult = ""Packet too big""" & vbCrLf
    code = code & "Case 11010: strResult = ""Request timed out""" & vbCrLf
    code = code & "Case 11011: strResult = ""Bad request""" & vbCrLf
    code = code & "Case 11012: strResult = ""Bad route""" & vbCrLf
    code = code & "Case 11013: strResult = ""Time-To-Live (TTL) expired transit""" & vbCrLf
    code = code & "Case 11014: strResult = ""Time-To-Live (TTL) expired reassembly""" & vbCrLf
    code = code & "Case 11015: strResult = ""Parameter problem""" & vbCrLf
    code = code & "Case 11016: strResult = ""Source quench""" & vbCrLf
    code = code & "Case 11017: strResult = ""Option too big""" & vbCrLf
    code = code & "Case 11018: strResult = ""Bad destination""" & vbCrLf
    code = code & "Case 11032: strResult = ""Negotiating IPSEC""" & vbCrLf
    code = code & "Case 11050: strResult = ""General failure""" & vbCrLf
    code = code & "Case Else: strResult = ""Unknown host""" & vbCrLf
    code = code & "End Select" & vbCrLf
    'code = code & "msgbox strResult" & vbCrLf
    code = code & "Next" & vbCrLf
    code = code & "Set objPing = Nothing" & vbCrLf
    code = code & "GetObject(, ""Excel.Application"").Workbooks(""" & ThisWorkbook.Name & """).Worksheets(1).Range(""B"" & WScript.Arguments(1))=strResult"
    x = FreeFile
    Open fichier For Output As #x
    Print #x, code
    Close #x
    'Debug.Print code
End Function

voila
dis moi que c'est moins rapide et plus lourd!!!

allez fait toi plaisir regarde dans les gestion de tache combien ca pompe par rapport au multithread de Excel ce qui est une hérésie

oulala !! j'ai bien bossé moi je vais boire un thé a toute

edit :
je peux même t'ajouter l'autodestruction du fichier quand le dernier ping est passé

en injectant simplement le rows end dans le vbs avec fso et delete fichier si le rows end correspond

**jurassic pork** · 19/11/2016, 00h44

hello,
Patrick avant d'agresser les gens tu ferais bien de regarder ce qui se dit ailleurs : ---> voir ici

Pour un ping c'est vrai que le vbs est certainement la meilleure solution mais pour d'autres cas de figure il faut voir (par exemple si c'est le vbs qui doit faire des opérations).

Ami calmant, J.P

**patricktoulon** · 19/11/2016, 01h34

re
non il ne s'agit en aucun d'agression mais cela exprime ma surprise surtout venant de toi qui nous pond des perles sorti de deux rues a droite après Jupiter

je suis même surpris que dans un de tes lien qui utilise une instance de VBS j'ai trouvé une boucle VBA (do/loop) d'attente de fin du travail du vbs ca c'est affreux

c'est la"Sub CheckIfFinished()"

alors que comme je l'ai dit cela peut être géré dans le vbs aussi et sans boucle

on fait le travail par vbs mais on bloque par un do/loop vba c'est même idiot ca sert a rien alors d'extérioriser une procédure
surtout quand on ce que ca pompe dans ta fenêtre de tache
tu imagine celui qui travaille avec un pc classique vendu souris en main dans les magasins de plus si c'est une marque donc avec des surcouches hoh!! le pauvre
non c'est vrai j'adhère pas c'est pas possible de dire je lance 20 fois Excel c'est inconcevable a mon avis

bon je reconnais qu'il y a quand même des choses intéressantes je vais regarder de plus prêt

je suis désolé si j'ai été un peu vif ca n'était pas mon intention

**Marc-L** · 19/11/2016, 14h54

En passant vite fait et sans agression aucune, on peut aussi de mémoire via une API Windows
lancer une tache en parallèle sans recourir à une seconde instance d'Excel !
Certes cela ne doit pas pouvoir s'appliquer à tous les cas.

Le VBScript n'est effectivement pas toujours plus rapide que le VBA mais dans le cas d'un besoin externe au VBA
d'une multitude d'appels en séquentiel alors le multi-taches Windows via VBScript est bien plus rapide …

Je n'ai jamais vu un langage aussi décrié comme le VBA auquel pourtant on lui demande autant !

**patricktoulon** · 19/11/2016, 17h37

re
tout a fait d'accords Marc

j'ai regarder son multithreadtool
woaoh!!!
pour l'expérience c'est beau pour la rentabilité VS vbscript direct un fichier vbs va 10 fois plus vite

ce que je trouve hallucinant c'est que le créateur créée un vbs pour lancer une macros VBA dans une instance du classeur sous un autre nom

faut vraiment être heu......

après pour l'exercice de style M..ouais!!....

j'aurais au moins appris: comment lancer une macro d'un classeur par VBS c'est pas perdu hein ....