Ping script launches and runs for termination time based on  HoursToRun. Arguments passed to script are "web.serv.address.local" or "google.com" style addresses. For each address passed as arguments it will watch stdout of dropouts and record the amount of time it was down.

Any suggestions to improve this are welcome. If you improve it please post back here so everyone benefits : )
Option Explicit
Const HoursToRun=24                 ''Script will terminate itself in x hours- if set to -1 script will not terminate until manually stopped

Const ForReading = 1         ''Open a file for reading only. You can't write to this file.
Const ForAppending = 8       ''Open a file and write to the end of the file.
Const TristateUseDefault = 2 ''Opens the file using the system default.
Const TristateTrue = 1       ''Opens the file 'as Unicode.
Const TristateFalse = 0      ''Opens the file 'as ASCII.

Const strSep = "|"      ''string separator - could be vbtab

Const dty = 1     ''yyyy
Const dtm = 2     ''mm      yyyy-mm    = 3
Const dtd = 4     ''dd      yyyy-mm-dd = 7
Const dth = 8     ''hh
Const dti = 16    ''mm
Const dta = 32    ''a/p     hhmma = 56
Const dts = 64    ''seconds
Const dtym = 3    ''1 + 2
Const dtymd = 7   ''1 + 2 + 4
Const dthma = 56  ''8 + 16 + 32
Const dtyALL = 63 ''1 + 2 + 4 + 8 + 16 + 32
Const dtallSS = 127 ''1 + 2 + 4 + 8 + 16 + 32 + 64''

Dim args

'''''''''''''Execute MAIN
main
''''''''''''''
'Public wscript As New objWSCRIPT_Emulator
''''''MAIN routine
Sub main()
   Dim i
   Dim args
   Dim strs
  
   Set args = wscript.Arguments
      if args.count = 0 then
            ReDim ComputerName(1)
            ComputerName(1)="Google.com"
      Else
            ReDim ComputerName(args.count)
           
            For i = 0 To args.count -1
                  strs = Trim(args(i))
                  ComputerName(i + 1) = args(i)
            Next
      end if
   PingCheck ComputerName
End Sub

''''''''PING test to check and watch for dropouts. Watches 2 servers at once, can be retooled to watch N() servers at once including google, etc.
''If all servers go down then local internet issue- if one goes down remote internet issue.
Function PingCheck(ByRef ComputerName)
  
  
   Dim ArgCt
   ArgCt = UBound(ComputerName)
  
   ReDim oShell(ArgCt) ''As WshShell
   ReDim oExec(ArgCt) ''As WshExec
   ReDim strText(ArgCt), strCmd(ArgCt) ''As String
   reDim timeStart(ArgCt)
   Dim timeScriptStart
   dim strFN
   Dim objfso 'as FileSystemObject
   Dim objfile 'as TextStream
   Dim WshNetwork, strComputer
   Dim QuitPing   ''to end program after closing all shells.
   Set WshNetwork = CreateObject("WScript.Network")
   strComputer = WshNetwork.ComputerName

   Dim i, II
   Dim StrMsg
  
   Set objfso = CreateObject("Scripting.FileSystemObject")

   ' How to writeline file
   timeStart(ArgCt) = Date + Time
   timeScriptStart = timeStart(ArgCt)
   strFN = Replace(wscript.ScriptFullName, wscript.ScriptName, "") & "Ping_Dropouts-" & datetime(dtymd, timeStart(argct)) & "-" & strComputer & ".txt"
   strmsg = "This will create a file: " & vbCr & strFN & vbCr & "that will create an entry every time the connection cannot be reached along with a duration of how long each hiccup is down"
      if HoursToRun > 0 then
            if HoursToRun >= 1 then
                  strmsg = strmsg & " over a duration of  " & HoursToRun & " Hours. Continue?"
            else
                  strmsg = strmsg & " over a duration of " & HoursToRun*60 & " Minutes. Continue?"
            end if
      else
            strmsg = strmsg & ". Continue?"
      end if
   If MsgBox(strmsg, vbYesNo) <> vbYes Then Exit Function
  
   Set objfile = objfso.OpenTextFile(strFN, ForAppending, True)

   objfile.WriteLine FormatLine("COMPUTER", "yyyy-mm-dd-hhnna", "ERROR", "Duration: ")
   For i = 1 To ArgCt
    ''''''''''''''''''FormatLine(strCompName, strDateTime, strErr, strDuration)
   objfile.WriteLine FormatLine(ComputerName(i), datetime(dtallSS, timeStart(i)), strText(i), ((Date + Time) - timeStart(i)) * 24 * 60 * 60)
   Next 'I
   Dim X

   For i = 1 To ArgCt
      strText(i) = ""
      strCmd(i) = "ping -t " & ComputerName(i)
      Set oShell(i) = CreateObject("WScript.Shell")
      Set oExec(i) = oShell(i).Exec(strCmd(i))
        timeStart(i) = Date + Time
  Next 'I
  
  
  
   ''Wscript.Echo datetime(dtallSS, timeStart(i)) & "START" & vbcr
  
   Do ''''''''''''''''''''''''''''''''''''''''''''''''''''''Primary loop to check continuous ping
      For i = 1 To ArgCt
            if (HoursToRun>0 and Date()+Time() > timeScriptStart +HoursToRun/24 ) _
            or oExec(i).StdOut.AtEndOfStream Then     ''''''''''''if any EOLs- e.g. windows closed, close out. or time greater than 12 hours
            QuitPing = True
            Exit Do
         End If
      Next 'I
        
      For i = 1 To ArgCt
         strText(i) = oExec(i).StdOut.ReadLine()
      
         If InStr(strText(i), "Request timed out.") > 0 Then    ''Could revamp to show excessive latency ... or value(mid (strtext(i),instr(strtext(i), "time=),3) > 65  ''ms
                                                                                                ''could also revamp- if count = argcount-1 then report outage : set count = 0 else count=count+1
           objfile.WriteLine FormatLine(ComputerName(i), datetime(dtallSS, timeStart(i)), strText(i), ((Date + Time) - timeStart(i)) * 24 * 60 * 60)
                                 
        Else
          timeStart(i) = Date + Time                                    ''Everything OK- reset reference time for last event
         End If
      Next 'I
   Loop

   For II = 1 To ArgCt
      oExec(II).Terminate
      Set oShell(II) = Nothing
      Set oExec(II) = Nothing
      strText(II) = ""
   Next 'II
   objfile.WriteLine FormatLine("EOL", datetime(dtallSS, timeStart(i)), "", "")
   objfile.Close
   wscript.quit 1
   Exit Function

End Function

Function datetime(ReturnFormat, timeDate)

If timeDate = 0 Then timeDate = Date + Time

''returns date in specified order
''const dty  =  1 ''yyyy
''const dtm  =  2  ''mm      yyyy-mm    = 3
''const dtd  =  4 ''dd      yyyy-mm-dd = 7
''const dth  =  8 ''hh
''const dti  = 16 ''mm
''const dta  = 32 ''a/p     hhmma = 56
''const dtym = 3     ''1 + 2
''const dtymd = 7 ''1 + 2 + 4
''const dthma = 56   ''8 + 16 + 32
''const dtyALL = 63  ''1 + 2 + 4 + 8 + 16 + 32
''If IsMissing(ReturnFormat) Then ReturnFormat = 63 ''everything
If ReturnFormat < 1 Then ReturnFormat = dtyALL

If ReturnFormat And dty Then datetime = datetime & StrFormat(Year(timeDate), 4, "0") & "-"
If ReturnFormat And dtm Then datetime = datetime & StrFormat(Month(timeDate), 2, "0") & "-"
If ReturnFormat And dtd Then datetime = datetime & StrFormat(Day(timeDate), 2, "0") & "-"
If ReturnFormat And dth Then datetime = datetime & StrFormat(Hour(timeDate), 2, "0")
If ReturnFormat And dti Then datetime = datetime & StrFormat(Minute(timeDate), 2, "0")
If ReturnFormat And dts Then datetime = datetime & StrFormat(Second(timeDate), 2, "0")
If ReturnFormat And dta Then
   If Time() >= 0.5 Then ''half day pm mark
     datetime = datetime & "p"
     Else
     datetime = datetime & "a"
   End If
End If
If Right(datetime, 1) = "-" Then datetime = Left(datetime, Len(datetime) - 1)
End Function


Function StrFormat(strText, intLength, strchr)
   'If IsMissing(strchr) Then strchr = " "
   If strchr = "" Then strchr = " "
   StrFormat = Right(String(intLength, strchr) & strText, intLength)
End Function

Function FormatLine(strCompName, strDateTime, strErr, strDuration)
   FormatLine = StrFormat(strCompName, 26, " ") & strSep _
             & StrFormat(strDateTime, 18, " ") & strSep _
           & StrFormat(strErr, 20, " ") & strSep _
           & StrFormat(strDuration, 16, " ") & vbCr
End Function



Comments

Popular posts from this blog

Powerpoint countdown and current time in slides VBA

Revit area plans adding new types and references (Gross and rentable)

Revit Python in Visual Studio Revit Stubs 2022 for Python Revit Intellisense