Powerpoint countdown and current time in slides VBA

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