Ping in Endlosschleife abfragen, stoppt nicht mehr
18.07.2008 13:48:24
Oliver
Leider kann ich die Endlosschleife, die per Button gestartet wird und eigentlich auch wieder gestoppt werden woll, trotz DoEvents auch nicht unterbrechen. Ich habe jetzt schon alles probiert. Hier mein aus dem Forum und eigenen Ideen zusammengebastelter Ansatz:
Sub CommandButton1_Click()
Dim rng As Range
If CommandButton1.Caption = "Start" Then
CommandButton1.Caption = "Stop"
Else
GoTo ende
End If
While CommandButton1.Caption = "Stop"
DoEvents
Set rng = Range("A2")
Do Until IsEmpty(rng.Value)
On Error Resume Next
v = Shell("cmd.exe /C ping " & rng.Value & ">C:\Ping" & rng.Value & ".txt")
If Err = 0 Then
Do
DoEvents
AppActivate v
Loop Until Err 0
On Error GoTo 0
Application.Wait 1000
Open "C:\Ping" & rng.Value & ".txt" For Input As #1
Do Until EOF(1)
Line Input #1, sTxt
If InStr(sTxt, "Verloren") Then
sTime = Right(sTxt, Len(sTxt) - InStr(sTxt, "Verloren") - 10)
sTime = Left(sTime, InStr(sTime, " (") - 1)
rng.Offset(0, 1).Value = sTime
End If
Loop
rng.Offset(0, 2).Value = "=NOW()"
rng.Offset(0, 2).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Close #1
Else
rng.Offset(0, 1) = "Failed to shell"
End If
Set rng = rng.Offset(1, 0)
Loop
Wend
ende:
CommandButton1.Caption = "Start"
End Sub