Test ping + courriel

Bonjour,

J'ai fouillé dans plusieurs forum et réussi à former un code amateur, mais le résultat n'est pas fiable...

Voici mon besoin: j'ai une liste d'adresses ip que veux faire un test ping et récupérer le résultat pour ensuite l'envoyer par courriel. j'aimerais que ce soit une routine à 10h00 tous les jours.

J'utilise tâche planifié pour la routine, mais ça ne semble pas fonctionner...

J'ai besoin d'un coup de main pour améliorer mon code et rendre le tout fonctionnel.

(Evidemment je ne suis pas programmeur, simplement débrouillard...)

Merci de votre aide c'est très apprécié.

Voici mon code pour l'instant:

Private Sub Workbook_Open()
Call callpg
End Sub

Sub callpg()
Call GetIPStatus
Application.Wait (Now + TimeValue("0:00:15"))
Call courriel
End Sub
Sub GetIPStatus()

  Dim Cell As Range
  Dim ipRng As Range
  Dim Result As String
  Dim Wks As Worksheet


Set Wks = Worksheets("TEST PING")

Set ipRng = Wks.Range("A6:A16")
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

    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 = "Communication ok"
         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 = "délai d'attente dépassé"
         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 courriel()


'Working in Office 2000-2010
Dim OutApp As Object
Dim OutMail As Object
Dim test(100) As String
Dim test2(100) As String
Dim test3(100) As String
Dim corp As String
Dim i As Integer
Dim L As Integer 'Déclaration de variable "L" pour connaitre la Ligne Numéro


'ici je repère la dernière ligne vide pour la Collections des données
L = Range("B65536").End(xlUp).Row + 1


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
For i = 1 To 12

test(i) = Cells(5 + i, 1)
test2(i) = Cells(5 + i, 2)
test3(i) = Cells(5 + i, 3)

Next
ttt = 1
For i = 1 To 12
corp = corp & vbCrLf & test3(i) & "    " & test2(i) & "    " & test(i)

Next
On Error Resume Next
With OutMail
.To = "***@***"
.CC = "***@***"
.BCC = ""
.Subject = "test communication bâtiment PDS"
.body = corp
.send

'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.display 'or use .Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub