Gruppe
Extern
Bereich
Internet
Thema
Pingwerte von WebServern auslesen
Problem
Die Pingwerte einer Liste von WebServern sollen in eine Tabelle eingetragen werden.
Lösung
Geben Sie den nachfolgenden Code in ein Standardmodul ein und weisen Sie ihn einer Schaltfläche zu.
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