Office: (Office 365) Aus Excel heraus verschiedene IP Adressen anpingen mit VBA

Hallo zusammen.
Vorweg: VBA kenn ich mich null aus! :-(
Mein Ziel erst einmal: In einer Tabelle stehen in der Spalte C von 8 bis 21 verschiedene IP-Adressen.
Per Klick auf einen Button soll dann ein Makro gestartet werden, was die IP Adressen jeweils anpingt. Wiederholend! Neben den IP Adressen (also in Spalte D ) soll einmal "Online" oder "Offline" stehen und in Spalte E die jeweilige Pingzeit (ms).
Jetzt kommt das Problem bzw. die Probleme.
1) Im Internet fand ich diverse Beispiele dazu. Allerdings nutzen alle dieses Skript dazu:

Code:

Function Ping(strip)
Dim objshell, boolcode
Set objshell = CreateObject("Wscript.Shell")
boolcode = objshell.Run("ping -n 1 -w 1000 " & strip, 0, True)
If boolcode = 0 Then
Ping = True
Else
Ping = False
End If
End Function

Dies kann ich aber nicht verwenden, da bei uns in der Domäne der Virenschutz dies verhindert. Also fand ich eine andere Alternative mit dieser Codevariante

Code:

Set wmi = GetObject("winmgmts://./root/cimv2")
qry = "select * FROM Win32_Pingstatus WHERE address='" & target & "'"

Da meckert der Virenschutz nicht. Mit etwas selbstgebastelt habe ich es dann auch hinbekommen. Allerdings bekomme ich dann immer nach einer Weile einen Überlauffehler oder "Nicht genügend Stapelspeicher". Wie gesagt, habe ich mir aus diversen Internetseiten da selbst was zusammengebastelt was sicherlich primitiv und kompliziert ist.

Wie müsste der Code aussehen, wo ich mit der WMI Variante arbeite und es mir die IPs aus C8:C21 anpingt und daneben mir die Ergebnisse anzeigt. Und zwar in Dauerschleife bis ich mit einem Button es wieder stoppe? Ich dreh nämlich langsam echt durch weil ich es nicht hinbekomme:-(

So sieht mein kompletter Code gerade aus:

Code:

Sub start()
Tabelle1.Range("e8:e21").ClearContents
Tabelle1.Range("G8").ClearContents
t = Timer + 10
pinging (t)

End Sub

Function rsp_time(target)
Set wmi = GetObject("winmgmts://./root/cimv2")
qry = "select * FROM Win32_Pingstatus WHERE address='" & target & "' And timeout = 4000"
rsptime = 1
CNT = 1
For Each pingstatus In wmi.execquery(qry)
If pingstatus.statuscode = 0 Then
rsptime = rsptime + pingstatus.responseTime
CNT = CNT + 1
End If
Next
rsp_time = rsptime / CNT
End Function

Function pinging(s)
If Tabelle1.Range("G8").Value = "Angehalten" Then
Exit Function
End If
Tabelle1.Range("G8").Value = "Aktiv"
t = Timer

If s = t Then
Exit Function
End If

Do Until Timer = t + 1
DoEvents
Loop
Dim target As String

target = Tabelle1.Range("c8").Value
Set rngl = Tabelle1.Range("E8")
lr = rngl.Count
Tabelle1.Cells(8, 5).Value = rsp_time(target)
For x = lr To 2 Step -1
Tabelle1.Cells(1 + x, 1).Value = Tabelle1.Cells(x, 1).Value
Next

target = Tabelle1.Range("c9").Value
Set rngl = Tabelle1.Range("E9")
lr2 = rngl.Count
Tabelle1.Cells(9, 5).Value = rsp_time(target)

For x2 = lr To 2 Step -1
Tabelle1.Cells(1 + x2, 1).Value = Tabelle1.Cells(x2, 1).Value
Next

target = Tabelle1.Range("c10").Value
Set rngl = Tabelle1.Range("e10")
lr3 = rngl.Count
Tabelle1.Cells(10, 5).Value = rsp_time(target)
For x3 = lr3 To 2 Step -1
Tabelle1.Cells(1 + x3, 1).Value = Tabelle1.Cells(x3, 1).Value
Next

target = Tabelle1.Range("c11").Value
Set rngl = Tabelle1.Range("e11")
lr3 = rngl.Count
Tabelle1.Cells(11, 5).Value = rsp_time(target)
For x4 = lr4 To 2 Step -1
Tabelle1.Cells(1 + x4, 1).Value = Tabelle1.Cells(x4, 1).Value
Next

target = Tabelle1.Range("c12").Value
Set rngl = Tabelle1.Range("e12")
lr5 = rngl.Count
Tabelle1.Cells(12, 5).Value = rsp_time(target)
For x5 = lr5 To 2 Step -1
Tabelle1.Cells(1 + x5, 1).Value = Tabelle1.Cells(x5, 1).Value
Next

target = Tabelle1.Range("c13").Value
Set rngl = Tabelle1.Range("e13")
lr6 = rngl.Count
Tabelle1.Cells(13, 5).Value = rsp_time(target)
For x6 = lr6 To 2 Step -1
Tabelle1.Cells(1 + x6, 1).Value = Tabelle1.Cells(x6, 1).Value
Next

target = Tabelle1.Range("c14").Value
Set rngl = Tabelle1.Range("e14")
lr7 = rngl.Count
Tabelle1.Cells(14, 5).Value = rsp_time(target)
For x7 = lr7 To 2 Step -1
Tabelle1.Cells(1 + x7, 1).Value = Tabelle1.Cells(x7, 1).Value
Next

target = Tabelle1.Range("c15").Value
Set rngl = Tabelle1.Range("e15")
lr8 = rngl.Count
Tabelle1.Cells(15, 5).Value = rsp_time(target)
For x8 = lr8 To 2 Step -1
Tabelle1.Cells(1 + x8, 1).Value = Tabelle1.Cells(x8, 1).Value
Next

target = Tabelle1.Range("c16").Value
Set rngl = Tabelle1.Range("e16")
lr8 = rngl.Count
Tabelle1.Cells(16, 5).Value = rsp_time(target)
For x9 = lr9 To 2 Step -1
Tabelle1.Cells(1 + x9, 1).Value = Tabelle1.Cells(x9, 1).Value
Next

target = Tabelle1.Range("c17").Value
Set rngl = Tabelle1.Range("e17")
lr8 = rngl.Count
Tabelle1.Cells(17, 5).Value = rsp_time(target)
For x10 = lr10 To 2 Step -1
Tabelle1.Cells(1 + x10, 1).Value = Tabelle1.Cells(x10, 1).Value
Next

target = Tabelle1.Range("c18").Value
Set rngl = Tabelle1.Range("e18")
lr8 = rngl.Count
Tabelle1.Cells(18, 5).Value = rsp_time(target)
For x11 = lr11 To 2 Step -1
Tabelle1.Cells(1 + x11, 1).Value = Tabelle1.Cells(x11, 1).Value
Next

target = Tabelle1.Range("c19").Value
Set rngl = Tabelle1.Range("e19")
lr8 = rngl.Count
Tabelle1.Cells(19, 5).Value = rsp_time(target)
For x12 = lr12 To 2 Step -1
Tabelle1.Cells(1 + x12, 1).Value = Tabelle1.Cells(x12, 1).Value
Next

target = Tabelle1.Range("c20").Value
Set rngl = Tabelle1.Range("e20")
lr8 = rngl.Count
Tabelle1.Cells(20, 5).Value = rsp_time(target)
For x13 = lr13 To 2 Step -1
Tabelle1.Cells(1 + x13, 1).Value = Tabelle1.Cells(x13, 1).Value
Next

target = Tabelle1.Range("c21").Value
Set rngl = Tabelle1.Range("e21")
lr8 = rngl.Count
Tabelle1.Cells(21, 5).Value = rsp_time(target)
For x14 = lr14 To 2 Step -1
Tabelle1.Cells(1 + x14, 1).Value = Tabelle1.Cells(x14, 1).Value
Next

Call pinging(s)

End Function
Sub Stop_ping()
Tabelle1.Range("G8").Value = "Angehalten"
End Sub

Danke im Voraus
Gruß
Micha

 

Hallo,

Du rufst die Funktion Pinging rekursiv immer wieder auf, ohne ein Kriterium für ein Ende zu definieren. Irgendwann ist der Stapelspeicher voll mit den Adessen der Aufrufe.

Grüße
Michael

 

Hmm, da ich, wie gesagt, null Ahnung von VBA habe: Wie könnte ich es dann lösen, dieses Problem? Welchen Wert müsste ich ändern ?

 

Hallo,

mit einer API sollte es gehen. Du musst nur die Übergabe der IP verallgemeinern:

Code:

Option Explicit
Private Declare Function gethostbyname Lib "WSOCK32.DLL" _
        (ByVal HostName As String) As Long
         
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal _
        wVersionRequired As Long, lpWSAData As WinSocketDataType) _
        As Long

Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long

Const WS_VERSION_REQD As Long = &H101&

Private Type HostDeType
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLength As Integer
    hAddrList As Long
End Type

Private Type WinSocketDataType
    wversion As Integer
    wHighVersion As Integer
    szDescription(0 To 128) As Byte
    szSystemStatus(0 To 256) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpszVendorInfo As Long
End Type

Private Function InitSocketAPI() As Long
    Dim Result As Integer
    Dim SocketData As WinSocketDataType
    InitSocketAPI = WSAStartup(WS_VERSION_REQD, SocketData)
End Function


Private Function Check_Connected(Name As String) As String
    Dim HostDeAddress As Long
  
    HostDeAddress = gethostbyname(Name)
    If HostDeAddress = 0 Then
        Check_Connected = "Keine Verbindung"
     Else
        Check_Connected = "Verbindung besteht"
    End If
   
End Function

'################## wird dann so aufgerufen ###########

Sub Pruefe_Verbindung()
  If InitSocketAPI = 0 Then
     MsgBox Check_Connected("192.168.178.1") ' hier die IP / oder Website eintragen 
     Call WSACleanup
  Else
     MsgBox ("Socket Error! Die Verbindung kann nicht geprüft werden")
  End If
End Sub

'http://www.herber.de/forum/archiv/1056to1060/1056144_Per_VBA_pruefen_ob_Online.html

mfg

 

Danke für das Skript. geht nur leider nicht da 64 Bit. Aber trotzdem Danke. Im Endeffekt müsste ich in mein Skript nur was einbauen, was das Makro selbst wiederholt und ich aber durch Drücken eines anderen Buttons dann stoppen kann. Hatte da auch schon was in der Art mal versucht.Nur konnte ich es nur mit "ESC" taste abbrechen was dann auch eine Fehlermeldung/Fenster erscheinen lässt.

 

Es funktioniert wenn mann der Wort PtrSafe einfügt.
Statt: Private Declare Function braucht man Private Declare PtrSafe Function überall.