Ping list of servers with VBS

Question

I have the following script which pings a list of servers (txt file with one server per line) and if down, records the info to a csv file. The script works, but I have two issues with the script that I can't figure out:

1) I would like the script to only create a file if one of the servers on the list is down. Currently, if no servers are down, it creates an empty file with a header row. I have temporarily fixed this by writing another script that later deletes the empty files, but it would be best if the file isn't created in the first place.

2) Is there a way to ping two or three times to double/triple check if a server is down, then record that it's down? Currently, the script is logging that sometimes a server is down when I don't think it actually is, maybe my internet connection or computer hangs for a second so the ping fails?

Thanks in advance! I'm just getting into VBS so this is unfamiliar territory for me.

Dim WshShell
Set WshShell = createobject("wscript.shell")
strURL = "www.yahoo.com"
set png = WshShell.exec("ping -n 1 " & strURL)
do until png.status = 1
wscript.sleep 100
loop
strPing = lcase(png.stdout.readall)
Select Case True
 Case InStr(strPing, "reply from") > 1 

dim strInputPath, strOutputPath, strStatus
dim objFSO, objTextIn, objTextOut

strSafeDate = DatePart("yyyy",Date) & Right("0" & DatePart("m",Date), 2) & Right("0" & DatePart("d",Date), 2)

strSafeTime = Right("0" & Hour(Now), 2) & Right("0" & Minute(Now), 2) & Right("0" & Second(Now), 2)

strDateTime = strSafeDate & "-" & strSafeTime

strInputPath = "C:\Users\user\Desktop\PING\serverlist.txt" '- location of input
strOutputPath = "C:\Users\user\Desktop\PING\log\" & strDateTime & ".csv" '- location of output
set objFSO = CreateObject("Scripting.FileSystemObject")
set objTextIn = objFSO.OpenTextFile( strInputPath,1 )
set objTextOut = objFSO.CreateTextFile( strOutputPath )
objTextOut.WriteLine("website,status,date")

Do until objTextIn.AtEndOfStream = True
    strComputer = objTextIn.ReadLine
        if fPingTest( strComputer ) then
             strStatus = "UP"
        else
             strStatus = "DOWN"
        end if
        if strStatus = "DOWN" then
              objTextOut.WriteLine(strComputer & "," & strStatus & "," & Now)
        end if
loop

function fPingTest( strComputer )
        dim objShell,objPing
        dim strPingOut, flag
        set objShell = CreateObject("Wscript.Shell")
        set objPing = objShell.Exec("ping " & strComputer)
    strPingOut = objPing.StdOut.ReadAll
    if instr(LCase(strPingOut), "reply") then
        flag = TRUE
        else
                flag = FALSE
        end if
        fPingTest = flag

end function

  Case Else
  End Select

Hackoo · Accepted Answer

You can try my modification code with a waiting bar if you want :

Option Explicit
Dim strInputPath,strOutputPath,strStatus,strSafeDate,strSafeTime,strDateTime,Titre,MsgTitre,MsgAttente
Dim objFSO,objTextIn,objTextOut,ReadAllFile,Lines,Line,Ws,Command,OpenCSVFile,oExec,Temp,StartTime,DurationTime
Set Ws = CreateObject("WScript.Shell")
Titre = "Ping list of servers"
MsgTitre = Titre
MsgAttente = "Please wait ... the pinging is on progress ...."
Temp = ws.ExpandEnvironmentStrings("%Temp%")
strSafeDate = DatePart("yyyy",Date) & Right("0" & DatePart("m",Date), 2) & Right("0" & DatePart("d",Date), 2)
strSafeTime = Right("0" & Hour(Now), 2) & Right("0" & Minute(Now), 2) & Right("0" & Second(Now), 2)
strDateTime = strSafeDate & "-" & strSafeTime
strInputPath = "C:\PingServer\serverlist.txt" '- location of input
strOutputPath = "C:\PingServer\" & strDateTime & ".csv" '- location of output
set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(strInputPath) Then
    set objTextIn = objFSO.OpenTextFile(strInputPath,1)
else
    MsgBox "CRITICAL ERROR " & VbCrLF & "The File "& DblQuote(strInputPath) & " dosen't exists !",VbCritical,"CRITICAL ERROR " & Titre
    Wscript.Quit
End if
set objTextOut = objFSO.CreateTextFile(strOutputPath)
objTextOut.WriteLine("website;status;date")
ReadAllFile = objTextIn.ReadAll
Lines = Split(ReadAllFile,vbCrLf)
Call CreateProgressBar(MsgTitre,MsgAttente)'Create the waiting Bar
Call LancerProgressBar()'Lancement de la barre de progression
StartTime = Timer 'Debut du Compteur Timer 
For Each Line In Lines
    If OnLine(Line) = True Then
        strStatus = "UP"
        objTextOut.WriteLine(Line & ";" & strStatus & ";" & Now)
    else
        strStatus = "DOWN"
        objTextOut.WriteLine(Line & ";" & strStatus & ";" & Now)
    end if
Next
Call FermerProgressBar()'Closing the waiting Bar
DurationTime = FormatNumber(Timer - StartTime, 0) & " seconds." 'La duree de l'execution du script
Command = "cmd /c CD " & DblQuote(ExcelPath()) & " | Start Excel.exe" &" /E "& DblQuote(strOutputPath)
Ws.Popup "The pinging Script is finshed in "& DurationTime,"2",MsgTitre,64
OpenCSVFile = ws.run(Command,0,False)
'************************************************************************************************************************************************************
Function OnLine(strHost)
    Dim objPing,z,objRetStatus,PingStatus
    Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address = '" & strHost & "'")
    z = 0
    Do   
        z = z + 1
        For Each objRetStatus In objPing
            If IsNull(objRetStatus.StatusCode) Or objRetStatus.StatusCode <> 0 Then
                PingStatus = False
            Else
                PingStatus = True
            End If     
        Next   
        Call Pause(1)
        If z = 5 Then Exit Do 'here you can incerase or decerase the value of z = 5
    Loop until PingStatus = True
    If PingStatus = True Then
        OnLine = True
    Else
        OnLine = False
    End If
End Function
'*********************************************************************************************
Sub Pause(NSeconds)
    Wscript.Sleep(NSeconds*1000)
End Sub
'**********************************************************************************************
Function ExcelPath()
    Dim appXL,s
    Set appXL = CreateObject("Excel.Application")
    ExcelPath = appXL.Path
    appXL.Quit
    Set appXL = Nothing
End Function
'**********************************************************************************************
'Fonction pour ajouter les doubles quotes dans une variable
Function DblQuote(Str)
    DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************************************
Sub CreateProgressBar(Titre,MsgAttente)
    Dim ws,fso,f,f2,ts,ts2,Ligne,i,fread,LireTout,NbLigneTotal,Temp,PathOutPutHTML,fhta,oExec
    Set ws = CreateObject("wscript.Shell")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Temp = WS.ExpandEnvironmentStrings("%Temp%")
    PathOutPutHTML = Temp & "\Barre.hta"
    Set fhta = fso.OpenTextFile(PathOutPutHTML,2,True)
    fhta.WriteLine ""
    fhta.WriteLine ""
    fhta.WriteLine "  " & Titre & ""
    fhta.WriteLine ""
    fhta.WriteLine ""
    fhta.WriteLine ""
    fhta.WriteLine "" & MsgAttente &""
    fhta.WriteLine "
"
    fhta.WriteLine ""
    fhta.WriteLine ""
    fhta.close
End Sub
'**********************************************************************************************
Sub LancerProgressBar()
    Set oExec = Ws.Exec("mshta.exe " & Temp & "\Barre.hta")
End Sub
'**********************************************************************************************
Sub FermerProgressBar()
    oExec.Terminate
End Sub
'**********************************************************************************************

Ping list of servers with VBS

Answers (2)

Related Questions