Use Excel 2010 VBA to ping a server and return up/down

[HunterTTP]

I have a list of servers that I would like to find out if they are on or not. I want to do this by pinging each server. On my work laptop I have the permissions necessary to ping each server individually in CMD and Powershell, but I cannot execute any scripts to allow me to automate the process.

I found this old thread from 7 years ago which seemed to answer the question - http://www.mrexcel.com/forum/excel-questions/391426-ping-list-servers-excel.html

But when I attempted to use the code, I get this error:

Any help is appreciated!

 

[RedBeard]

Google gave me this: Ping IP Address with VBA code and return results in Excel - Stack Overflow

 

[HunterTTP]

Google gave me this: Ping IP Address with VBA code and return results in Excel - Stack Overflow

This works perfectly. Thanks so much!

Final code I used:

   'This function does the pinging
   Function GetPingResult(Host)
   
   'declaring variables
   Dim objPing As Object
   Dim objStatus As Object
   Dim Result As String
   
   'ping the host
   Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
       ExecQuery("Select * from Win32_PingStatus Where Address = '" & Host & "'")
       
   'report the results
   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
   
   'reset object ping variable
   Set objPing = Nothing


End Function


'this sub calls the above function using a for each loop
Sub GetIPStatus()


'this clears the current Ping Status column (not necessary but visually helpful
Worksheets("Sheet1").Range("B2:B10000").Clear


'declaring variables
  Dim Cell As Range
  Dim ipRng As Range
  Dim Result As String
  Dim Wks As Worksheet
  Dim StartTime As Double
  Dim SecondsElapsed As Double


'this starts a time to see how long the status check takes
StartTime = Timer


'setting values of variables
Set Wks = Worksheets("Sheet1")
Set ipRng = Wks.Range("A2")
Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)
Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))


'this is a loop that feeds each server from the list into the GetPingResult function
  For Each Cell In ipRng
    Result = GetPingResult(Cell)
    Cell.Offset(0, 1) = Result
  Next Cell


'this calculates the time it took to run the script and converts it to minutes
SecondsElapsed = Round(Round(Timer - StartTime, 2) / 60)


'this displays the final time taken and lets the user know everything has completed
MsgBox "This code ran successfully in " & SecondsElapsed & " minutes", vbInformation


End Sub