Thema: Pingwerte von WebServern auslesen

StandardModule: Modul1

Sub PingHWHSites()
   Dim rng As Range
   Dim v As Variant
   Dim iCounter As Integer
   Dim sTxt As String, sTime As String, sFile As String
   sFile = Application.DefaultFilePath & "\Ping.txt"
   Close
   Set rng = Range("A2")
   Do Until IsEmpty(rng.Value)
      On Error Resume Next
      If InStr(Application.OperatingSystem, "NT") Then
         v = Shell("cmd.exe /C ping " & rng.Value & ">" & sFile)
      Else
         MsgBox "Bitte beachten:" & vbLf & "Die Routine funktioniert" & _
            " nur auf NT-Systemen zuverlässig!"
         v = Shell("command.com /C ping " & rng.Value & ">" & sFile)
      End If
      If Err = 0 Then
         Do
            DoEvents
            AppActivate v
         Loop Until Err <> 0
         On Error GoTo 0
         Open sFile For Input As #1
         Do Until EOF(1)
            Line Input #1, sTxt
            If InStr(sTxt, "Minimum") Then
               sTime = Right(sTxt, Len(sTxt) - InStr(sTxt, "Minimum") - 9)
               sTime = Left(sTime, InStr(sTime, ",") - 1)
               rng.Offset(0, 1).Value = sTime
            End If
            If InStr(sTxt, "Maximum") Then
               sTime = Right(sTxt, Len(sTxt) - InStr(sTxt, "Maximum") - 9)
               sTime = Left(sTime, InStr(sTime, ",") - 1)
               rng.Offset(0, 2).Value = sTime
            End If
            If InStr(sTxt, "Mittelwert") Then
               sTime = Right(sTxt, Len(sTxt) - InStr(sTxt, "Mittelwert") - 11)
               rng.Offset(0, 3).Value = sTime
            End If
         Loop
         Close #1
      Else
         rng.Offset(0, 1) = "Failed to shell"
      End If
      Set rng = rng.Offset(1, 0)
   Loop
End Sub

Beiträge aus dem Excel-Forum zu den Themen Extern und Internet