Adresse IP ping avec le code VBA et retourne les résultats dans Excel

J'ai un code visual basic (voir ci-dessous) qui teste une connexion IP dans la colonne B (d'une feuille de calcul excel, et la pose de savoir si ou non il est connecté ou non accessible dans la colonne c, je me demandais juste si vous pouviez m'aider, j'aimerais qu'il soit vert si "connecté", et tout autre résultat serait rouge.

Aussi, pourrait ce script s'exécuter automatiquement, sur une base horaire ou quotidienne?

Merci Beaucoup,
Andy

Function GetPingResult(Host)
Dim objPing As Object
Dim objStatus As Object
Dim strResult 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("Sheet1")
Set ipRng = Wks.Range("B3")
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
Next Cell
End Sub

source d'informationauteur Andy

  1. 4

    Vous n'avez pas besoin de code pour cela. Tourner toutes les cellules en rouge, puis ajouter la mise en forme conditionnelle à rendre vert quand vous le voulez.

    Accueil > mise en forme Conditionnelle > Nouvelle Règle > Utiliser une formule...

    =C2="Connected"

    et le format de vert. Si vous voulez le faire dans le code, vous pouvez ajouter quelques lignes dans votre Pour Chaque boucle

    If Result = "Connected" Then
Cell.Offset(0,1).Font.Color = vbGreen
Else
Cell.Offset(0,1).Font.Color = vbRed
End If
  2. 1

    D'avoir cette exécuté automatiquement à certains intervalles, découvrez de ce lien.

    Voici le code correspondant:

    Public dTime As Date
Dim lNum As Long
Sub RunOnTime()
dTime = Now + TimeSerial(0, 0, 10) 'Change this to set your interval
Application.OnTime dTime, "RunOnTime"
lNum = lNum + 1
If lNum = 3 Then
Run "CancelOnTime" 'You could probably omit an end time, but I think the program would eventually crash
Else
MsgBox lNum
End If
End Sub
Sub CancelOnTime()
Application.OnTime dTime, "RunOnTime", , False
End Sub

    Je recommande d'inclure une ThisWorkbook.Save ligne que je ne peux pas parler de combien de temps cela va fonctionner sans panne, et j'imagine que vous pourriez voir des problèmes si vous l'avez laissé pendant des jours à la fois.