XL 2010 Tester réponse serveur SMTP

[blord]

Bonjour à tous,

J'utilise CDO pour envoyer environ 400 à 500 courriels par mois.
Ce que j'aimerais faire, c'est de tester si le serveur est "up" avant l'envoi de chaque courriel afin de prévenir l'échec de l'envoi...

Existe-t-il une façon rapide de faire un genre de test "ping" sur le serveur afin de savoir si ce dernier "répond" ??

Merci pour vos suggestions !
Blord

    Dim oMessage As Object
    Dim oConfig As Object
    Dim oChamps As Object

    Set oConfig = CreateObject("CDO.Configuration")
    oConfig.Load -1
    Set oChamps = oConfig.Fields

    With oChamps
       .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'cdoSendUsingPickup(1) = Send message using the local SMTP service pickup directory / cdoSendUsingPort(2) = Send the message using the network (SMTP over the network)
       .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "abcde.fghij.com"
       .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
       .Update
    End With

    Set oMessage = CreateObject("CDO.Message")

 

[Compte Supprimé 979]

Bonjour Blord,

Un exemple de code pour une liste de serveurs dans une feuille, à adapter ;-)

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, RngEnd 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

A+

 

[blord]

Bonjour Bruno,

Merci d'avoir pris de ton temps pour me répondre....
Je vais tester dans les prochains jours....

Bonne fin de journée....

 

[blord]

Bonjour à nouveau....

Je viens de tester le code et tout est OK....
Encore une fois, merci beaucoup pour ton aide...