PDA

Vollständige Version anzeigen : Erreichbarkeit mit Ping messn


TobiasKornmayer
13.03.2009, 11:46
Hallo liebe Member,
um das Firmennetzwerk etwas zu evaluieren und die Server auf Erreichbarkeit zu testen, möchte ich einen Ping aus Excel starten. Ich habe eine Lösung gefunden (also nicht von mir) die zwar gute ergebnisse liefert, aber sehr viel Zeit benötigt, da jedes mal der Rechnername aufgelöst wird (wie mir scheint), hier der Code:

Option Explicit

Const SOCKET_ERROR = 0
Const MAX_IP = 10

Private Type WSAdata
wVersion As Integer
wHighVersion As Integer
szDescription(0 To 255) As Byte
szSystemStatus(0 To 128) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type

Private Type Hostent
h_name As Long
h_aliases As Long
h_addrtype As Integer
h_length As Integer
h_addr_list As Long
End Type

Private Type IP_OPTION_INFORMATION
TTL As Byte
Tos As Byte
Flags As Byte
OptionsSize As Long
OptionsData As String * 128
End Type

Private Type IP_ECHO_REPLY
Address(0 To 3) As Byte
Status As Long
RoundTripTime As Long
DataSize As Integer
Reserved As Integer
data As Long
Options As IP_OPTION_INFORMATION
End Type

Private Declare Function GetHostByName Lib "wsock32.dll" Alias "gethostbyname" (ByVal HostName As String) As Long
Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired&, lpWSAdata As WSAdata) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal HANDLE As Long) As Boolean
Private Declare Function IcmpSendEcho Lib "ICMP" (ByVal IcmpHandle As Long, ByVal DestAddress As Long, ByVal RequestData As String, ByVal RequestSize As Integer, RequestOptns As IP_OPTION_INFORMATION, ReplyBuffer As IP_ECHO_REPLY, ByVal ReplySize As Long, ByVal Timeout As Long) As Boolean

Public Function Ping(sAddr As String, Optional Timeout As Integer = 2000) As Integer
Dim hFile As Long, lpWSAdata As WSAdata
Dim hHostent As Hostent, AddrList As Long
Dim Address As Long, rIP As String
Dim OptInfo As IP_OPTION_INFORMATION
Dim EchoReply As IP_ECHO_REPLY

Call WSAStartup(&H101, lpWSAdata)

If GetHostByName(sAddr + String(64 - Len(sAddr), 0)) <> SOCKET_ERROR Then
CopyMemory hHostent.h_name, ByVal GetHostByName(sAddr + String(64 - Len(sAddr), 0)), Len(hHostent)
CopyMemory AddrList, ByVal hHostent.h_addr_list, 4
CopyMemory Address, ByVal AddrList, 4
End If

hFile = IcmpCreateFile()

If hFile = 0 Then
Ping = -2 ' MsgBox "Unable to Create File Handle"
Exit Function
End If

OptInfo.TTL = 255

If IcmpSendEcho(hFile, Address, String(32, "A"), 32, OptInfo, EchoReply, Len(EchoReply) + 8, Timeout) Then
rIP = CStr(EchoReply.Address(0)) + "." + CStr(EchoReply.Address(1)) + "." + CStr(EchoReply.Address(2)) + "." + CStr(EchoReply.Address(3))
Else
Ping = -1
End If

If EchoReply.Status = 0 Then
Ping = EchoReply.RoundTripTime
Else
Ping = -3 'means request timed out
End If

IcmpCloseHandle hFile
WSACleanup

Und folgende Lösung liefert zwar eine Zeit in ms, arbeitet aber nicht korrekt:

Private Declare Function InternetQueryOption Lib "wininet" Alias "InternetQueryOptionA" (ByVal hInternet As Long, ByVal dwOption As Long, ByRef lpBuffer As Long, ByRef dwBufferLength As Long) As Long
Private Const INTERNET_OPTION_CONNECTED_STATE = 50
Private Const INTERNET_STATE_DISCONNECTED_BY_USER = &H10
' Benötigte API-Deklaration für Server anpingen
Private Declare Function IsDestinationReachable Lib "Sensapi.dll" Alias "IsDestinationReachableA" (ByVal lpszDestination As String, lpQOCInfo As QOCINFO) As Long
Private Type QOCINFO
dwSize As Long
dwflags As Long
dwInSpeed As Long
dwOutSpeed As Long
End Type

Private Function SystemOffline() As Boolean ' Globaler Offline-Modus gestartet?
On Error GoTo ErrHandler
Dim lState As Long
If InternetQueryOption(0, INTERNET_OPTION_CONNECTED_STATE, lState, Len(lState)) <> 0 Then
SystemOffline = (lState And INTERNET_STATE_DISCONNECTED_BY_USER)
End If
Exit Function
ErrHandler:
Resume Next
End Function

Public Function Ping2(ByVal sHost As String) As Single ' Server anpingen und Reaktionszeit zurückgeben
On Error GoTo ErrHandler
Dim QI As QOCINFO
Dim vTime As Single
QI.dwSize = Len(QI)
vTime = Timer
If IsDestinationReachable(sHost, QI) = 1 Then
Ping2 = Timer - vTime
Else
Ping2 = -1
End If
Exit Function
ErrHandler:
Resume Next
End Function

Das Herber-Makro habe ich bereits gefunden, wollte aber innerhalb von excel bleiben. Auch ein anderes Makro ist mir bekannt, bei dem aber immer die Shell aufpoppt, was auch nicht so toll ist.

Weiß jemand wie man im ersten Makro Die Namensauflösung umgehen kann?
Oder hat jemand einen anderen Ansatz?

Vielen Dank für eure Hilfe,

Tobias

IngGi
13.03.2009, 13:05
Hallo Tobias,

wenn ich das richtig sehe, springst du für jeden anzupingenden PC die Funktion Ping an, wartest auf die Rückmeldung und machst dann in einer Schleife beim nächsten PC weiter. Das dauert deshalb so lange, weil ein Ping, solange er nicht erfolgreich ist, bis zu vier Mal gesendet und dazwischen immer eine Zeit lang auf Rückmeldung gewartet wird. In dieser Zeit passiert erstmal nichts. Erst nach dem vierten erfolglosen Versuch erfolgt dann eine Rückmeldung an den Sender des Pings.

Ich habe vor einiger Zeit folgendes Makro geschrieben, das einen etwas anderen Ansatz hat. Das Makro wartet nicht bei jedem einzelnen PC auf Rückmeldung, sondern schickt erstmal Pings an alle PCs los. Die Rückmeldungen werden dann unabhängig vom weiteren Makroablauf in eine Textdatei geschrieben. Für jeden PC erzeugt das Makro vorab eine solche (leere) Textdatei. Nach dem Abschicken der Pings werden diese Textdateien dann in einer Schleife immer wieder durchlaufen und es wird geprüft, ob eine Rückmeldung darin steht. Diese Rückmeldung wird dann ausgewertet und in die Exceltabelle eingetragen.

Folgendes ist zu beachten. Du musst zunächst einen Ordner C:\Ping\ für die Rückmeldungsdateien anlegen. Falls du keine Administratorrechte auf dem PC hast, musst du den Ordner irgendwo in deinem Userpfad anlegen und das im Makro anpassen. Das Makro kommt in ein allgemeines Modul. In Tabelle1 der Arbeitsmappe stehen in Spalte A ab A2 entweder die Namen oder die IP-Nummern der anzupingenden PCs. In Spalte B wird zu jedem PC AN oder AUS zurückgegeben. Die Zelle A1 muss leer sein, es sei denn, du möchtest den Ping in Intervallen automatisch wiederholen. In diesem Fall kannst du in die Zelle A1 eine Intervallzeit im Format hh:mm:ss eingeben. In die erste Zeile der Spalte B (und weiterer Spalten bei Intervallwiederholung) wird der Zeitpunkt der Pings eingetragen. In meiner Mappe habe ich über die Zelle A1 den Startbutton für das Makro gelegt.

<div><link href="http://www.ms-office-forum.net/forum/externals/codeconv.css" rel="stylesheet"><pre><span class="TOKEN">Option</span> <span class="TOKEN">Explicit</span>
&nbsp;
<span class="TOKEN">Sub</span> Pingen()
&nbsp;
<span class="REM">'Systemzeit zum Eintragen in Tabellenkopf und f&uuml;r</span>
<span class="REM">'Mehrfachausf&uuml;hrung in Zeitintervallen</span>
<span class="TOKEN">Dim</span> dtmIntervall <span class="TOKEN">As</span> Date
&nbsp;
<span class="REM">'Bereiche f&uuml;r PC-Namen, R&uuml;ckgabewerte, Mitarbeiterzuordnung, Schleifenvariablen</span>
<span class="TOKEN">Dim</span> rngPCs <span class="TOKEN">As</span> Range
<span class="TOKEN">Dim</span> rngAnAus <span class="TOKEN">As</span> Range
<span class="TOKEN">Dim</span> rngMitarbeiter <span class="TOKEN">As</span> Range
<span class="TOKEN">Dim</span> rngAlleMitarbeiter <span class="TOKEN">As</span> Range
<span class="TOKEN">Dim</span> rng <span class="TOKEN">As</span> Range
<span class="TOKEN">Dim</span> lngZeile <span class="TOKEN">As</span> <span class="TOKEN">Long</span>
&nbsp;
<span class="REM">'Kanalnummer zu Textdateien f&uuml;r R&uuml;ckgabewerte</span>
<span class="TOKEN">Dim</span> intFF <span class="TOKEN">As</span> <span class="TOKEN">Integer</span>
&nbsp;
<span class="REM">'Stringvariablen f&uuml;r PCs und R&uuml;ckgabetext</span>
<span class="TOKEN">Dim</span> strSNI <span class="TOKEN">As</span> <span class="TOKEN">String</span>
<span class="TOKEN">Dim</span> strPCan <span class="TOKEN">As</span> <span class="TOKEN">String</span>
&nbsp;
<span class="REM">'Variablen f&uuml;r Dateizugriff (FSO)</span>
<span class="TOKEN">Dim</span> objFSO <span class="TOKEN">As</span> Object
<span class="TOKEN">Dim</span> objFolder <span class="TOKEN">As</span> Object
<span class="TOKEN">Dim</span> objFile <span class="TOKEN">As</span> Object
&nbsp;
<span class="REM">'Z&auml;hler und File f&uuml;r Pr&uuml;fung, ob Pings im Nirvana verschwunden sind</span>
<span class="TOKEN">Dim</span> lngCount <span class="TOKEN">As</span> <span class="TOKEN">Long</span>
<span class="TOKEN">Dim</span> objFileNirvana <span class="TOKEN">As</span> Object
&nbsp;
<span class="REM">'----------------------------------------------------------------------------------</span>
<span class="REM">'----------------------------------------------------------------------------------</span>
&nbsp;
&nbsp;
<span class="REM">'Systemzeit in Variable, damit einheitlich w&auml;hrend Ausf&uuml;hrung</span>
dtmIntervall = Now
&nbsp;
<span class="REM">'Ausf&uuml;hrungshinweis auf Button</span>
Tabelle1.cmdStart.Caption = &quot;Ping...&quot;
Application.Wait Now + TimeValue(&quot;00:00:01&quot;)
&nbsp;
<span class="REM">'Bereiche f&uuml;r PC-Namen und R&uuml;ckgabewerte ermitteln</span>
<span class="TOKEN">Set</span> rngPCs = Tabelle1.Range(&quot;C2:C&quot; &amp; Tabelle1.Range(&quot;C2&quot;).End(xlDown).Row)
<span class="REM">'Wenn keine PCs eingetragen sind ...</span>
<span class="TOKEN">If</span> rngPCs.Resize(1, 1) = &quot;&quot; <span class="TOKEN">Then</span>
<span class="REM"> '...Nachricht und abbrechen.</span>
MsgBox &quot;Kein PC eingetragen! Abbruch.&quot;, vbCritical
<span class="TOKEN">Exit Sub</span>
<span class="REM">'Wenn nur ein PC eingetragen, Bereich anpassen</span>
<span class="TOKEN">ElseIf</span> rngPCs.Resize(1, 1).Offset(1, 0) = &quot;&quot; <span class="TOKEN">Then</span>
<span class="TOKEN">Set</span> rngPCs = rngPCs.Resize(1, 1)
<span class="TOKEN">End</span> <span class="TOKEN">If</span>
<span class="REM">'Bereich f&uuml;r R&uuml;ckgabewerte ermitteln</span>
<span class="TOKEN">Set</span> rngAnAus = rngPCs.Offset(0, 1)
&nbsp;
<span class="REM">'Systemzeit in Tabellenkopf eintragen</span>
rngAnAus.Resize(1, 1).Offset(-1, 0) = Format(dtmIntervall, &quot;hh:mm:ss&quot;)
&nbsp;
<span class="REM">'FSO f&uuml;r Zugriff auf Dateien mit den R&uuml;ckgabewerten vorbereiten</span>
<span class="TOKEN">Set</span> objFSO = CreateObject(&quot;Scripting.FileSystemObject&quot;)
<span class="TOKEN">Set</span> objFolder = objFSO.GetFolder(&quot;C:\Pings&quot;)
&nbsp;
<span class="REM">'Alte Ausgabedateien l&ouml;schen</span>
<span class="TOKEN">For</span> <span class="TOKEN">Each</span> objFile <span class="TOKEN">In</span> objFolder.Files
Kill objFile.Path
<span class="TOKEN">Next</span> <span class="REM">'objFile</span>
&nbsp;
<span class="REM">'Pro PC eine Ausgabedatei erstellen</span>
<span class="TOKEN">For</span> <span class="TOKEN">Each</span> rng <span class="TOKEN">In</span> rngPCs
objFolder.CreateTextFile rng &amp; &quot;.txt&quot;
<span class="TOKEN">Next</span> <span class="REM">'rng</span>
&nbsp;
<span class="REM">'PCs anpingen und R&uuml;ckgabewert in Ausgabedatei umleiten</span>
<span class="TOKEN">For</span> <span class="TOKEN">Each</span> rng <span class="TOKEN">In</span> rngPCs
Shell &quot;cmd.exe /C Ping &quot; &amp; rng &amp; &quot; &gt;C:\Pings\&quot; &amp; rng &amp; &quot;.txt&quot;
<span class="TOKEN">Next</span> <span class="REM">'rng</span>
&nbsp;
<span class="REM">'Solange Ausgabedatei in Ordner vorhanden</span>
<span class="TOKEN">Do</span> <span class="TOKEN">While</span> objFolder.Files.Count &gt; 0
<span class="TOKEN">For</span> <span class="TOKEN">Each</span> objFile <span class="TOKEN">In</span> objFolder.Files
<span class="REM"> 'Wenn R&uuml;ckmeldung in Ausgabedatei</span>
<span class="TOKEN">If</span> objFile.Size &gt; 0 <span class="TOKEN">Then</span>
<span class="REM"> 'Ausgabedatei &ouml;ffnen und Inhalt einlesen</span>
intFF = FreeFile
<span class="TOKEN">Open</span> objFile.Path <span class="TOKEN">For</span> <span class="TOKEN">Input</span> <span class="TOKEN">As</span> #intFF
strPCan = <span class="TOKEN">Input</span>(LOF(intFF), #intFF)
<span class="TOKEN">Close</span> #intFF
&nbsp;
<span class="REM"> 'Wenn Ping erfolglos</span>
<span class="TOKEN">If</span> InStr(1, strPCan, &quot;100% Verlust&quot;) &gt; 0 <span class="TOKEN">Then</span>
<span class="REM"> 'Zeile f&uuml;r den PC suchen und Ergebnis eintragen</span>
<span class="TOKEN">For</span> <span class="TOKEN">Each</span> rng <span class="TOKEN">In</span> rngPCs
<span class="TOKEN">If</span> rng = Left(objFile.Name, Len(objFile.Name) - 4) <span class="TOKEN">Then</span>
rng.Offset(0, rngAnAus.Column - rngPCs.Column) = &quot;AUS&quot;
<span class="TOKEN">Exit For</span>
<span class="TOKEN">End</span> <span class="TOKEN">If</span>
<span class="TOKEN">Next</span> <span class="REM">'rng</span>
<span class="REM"> 'Wenn Ping erfolgreich</span>
<span class="TOKEN">ElseIf</span> InStr(1, strPCan, &quot;Antwort von&quot;) &gt; 0 <span class="TOKEN">Then</span>
<span class="REM"> 'Zeile f&uuml;r den PC suchen und Ergebnis eintragen</span>
<span class="TOKEN">For</span> <span class="TOKEN">Each</span> rng <span class="TOKEN">In</span> rngPCs
<span class="TOKEN">If</span> rng = Left(objFile.Name, Len(objFile.Name) - 4) <span class="TOKEN">Then</span>
rng.Offset(0, rngAnAus.Column - rngPCs.Column) = &quot;AN&quot;
<span class="TOKEN">Exit For</span>
<span class="TOKEN">End</span> <span class="TOKEN">If</span>
<span class="TOKEN">Next</span> <span class="REM">'rng</span>
<span class="TOKEN">End</span> <span class="TOKEN">If</span>
<span class="REM"> 'Ausgabedatei l&ouml;schen</span>
<span class="TOKEN">Do</span>
<span class="TOKEN">On</span> <span class="TOKEN">Error</span> <span class="TOKEN">Resume</span> <span class="TOKEN">Next</span>
Kill objFile.Path
<span class="TOKEN">Loop</span> <span class="TOKEN">Until</span> Err.Number &gt; 0
<span class="TOKEN">End</span> <span class="TOKEN">If</span>
<span class="TOKEN">Next</span> <span class="REM">'objFile</span>
lngCount = lngCount + 1
<span class="TOKEN">If</span> lngCount Mod 100000 = 0 <span class="TOKEN">Then</span>
<span class="TOKEN">For</span> <span class="TOKEN">Each</span> objFileNirvana <span class="TOKEN">In</span> objFolder.Files
Shell &quot;cmd.exe /C Ping &quot; &amp; Left(objFileNirvana.Name, 8) _
&amp; &quot; &gt;C:\Pings\&quot; &amp; objFileNirvana.Name
<span class="TOKEN">Next</span> <span class="REM">'objFileNirvana</span>
<span class="TOKEN">End</span> <span class="TOKEN">If</span>
<span class="TOKEN">Loop</span> <span class="REM">'Do While objFolder.Files.Count &gt; 0</span>
&nbsp;
<span class="REM">'Neue Spalte f&uuml;r n&auml;chste Ergebnisse</span>
<span class="TOKEN">If</span> Tabelle1.Range(&quot;A1&quot;) &lt;&gt; &quot;&quot; <span class="TOKEN">Then</span> rngAnAus.EntireColumn.Insert
&nbsp;
<span class="REM">'Ausf&uuml;hrungshinweis auf Button l&ouml;schen</span>
Tabelle1.cmdStart.Caption = &quot;Start&quot;
&nbsp;
<span class="REM">'Wenn Zeitintervall angegeben, Makro neu aufrufen</span>
<span class="TOKEN">If</span> Tabelle1.Range(&quot;A1&quot;) &lt;&gt; &quot;&quot; <span class="TOKEN">Then</span>
Application.OnTime dtmIntervall + Range(&quot;A1&quot;), &quot;Pingen&quot;
<span class="TOKEN">End</span> <span class="TOKEN">If</span>
&nbsp;
<span class="TOKEN">End</span> <span class="TOKEN">Sub</span></pre></div>
Code eingefügt mit dem MOF Code Converter (http://www.ms-office-forum.net/forum/codeconverter.php)

Gruß Ingolf

TobiasKornmayer
13.03.2009, 14:21
Hi Ingolf,
tolles Makro hast du da gemacht. Ist es möglich, auch den Timeout auszulesen?

Gruß,
Tobias

TobiasKornmayer
13.03.2009, 14:35
Also ich hab das Makro mal probiert, aber irgendwie verschwinden die txt-dateien wieder, nachdem ich es ausgeführt habe. und eingetragen wurde ebenfalls nichts. ich musste es etwas anpassen, da die PCs anscheinend in Spalte C eingetragen waren. Naja, das einzige was etwas stört ist, dass dann für jeden PC eine cmd aufpömpelt.

Tobias

IngGi
13.03.2009, 15:49
Hallo Tobias,

sorry, das mit Spalte C stimmt natürlich. Ich habe bei mir in den Spalten A und B noch die UserIDs und Namen der Mitarbeiter stehen. Da habe ich die UserIDs mit den PC-Namen verwechselt. Das die Textdateien wieder verschwinden ist Absicht. Sie werden in der Schleife, in der auf die Rückmeldungen gewartet wird gelöscht, sobald ein Rückgabewert gefunden und ausgewertet wurde. Die Schleife läuft dann einfach weiter, bis keine Datei mehr im Ordner existiert.

Jetzt habe ich das Makro mal ein wenig an deine Wünsche angepasst:


Die PC-Namen oder IP-Nummern der PCs kommen jetzt tatsächlich in Spalte A. Die Rückgabemeldungen werden in Spalte B ausgegeben.
Die DOSen werden im Hintergrund gehalten.
An Stelle von AN und AUS werden nun die kompletten Rückmeldungen in Spalte B des Tabellenblattes ausgegeben.
Über eine bedingte Formatierung werden in der Rückgabespalte alle Zellen mit erfolgreichem Ping grün und diejenigen mit erfolglosem Ping rot gekennzeichnet.

Ich habe dir mal eine Arbeitsmappe hochgeladen. Hier aber trotzdem nochmal der angepasste Makrocode:

<div><link href="http://www.ms-office-forum.net/forum/externals/codeconv.css" rel="stylesheet"><pre><span class="TOKEN">Sub</span> Pingen()
&nbsp;
<span class="REM">'Systemzeit zum Eintragen in Tabellenkopf und f&uuml;r</span>
<span class="REM">'Mehrfachausf&uuml;hrung in Zeitintervallen</span>
<span class="TOKEN">Dim</span> dtmIntervall <span class="TOKEN">As</span> Date
&nbsp;
<span class="REM">'Bereiche f&uuml;r PC-Namen, R&uuml;ckgabewerte, Mitarbeiterzuordnung, Schleifenvariablen</span>
<span class="TOKEN">Dim</span> rngPCs <span class="TOKEN">As</span> Range
<span class="TOKEN">Dim</span> rngAnAus <span class="TOKEN">As</span> Range
<span class="TOKEN">Dim</span> rngMitarbeiter <span class="TOKEN">As</span> Range
<span class="TOKEN">Dim</span> rngAlleMitarbeiter <span class="TOKEN">As</span> Range
<span class="TOKEN">Dim</span> rng <span class="TOKEN">As</span> Range
<span class="TOKEN">Dim</span> lngZeile <span class="TOKEN">As</span> <span class="TOKEN">Long</span>
&nbsp;
<span class="REM">'Kanalnummer zu Textdateien f&uuml;r R&uuml;ckgabewerte</span>
<span class="TOKEN">Dim</span> intFF <span class="TOKEN">As</span> <span class="TOKEN">Integer</span>
&nbsp;
<span class="REM">'Stringvariablen f&uuml;r PCs und R&uuml;ckgabetext</span>
<span class="TOKEN">Dim</span> strSNI <span class="TOKEN">As</span> <span class="TOKEN">String</span>
<span class="TOKEN">Dim</span> strPCan <span class="TOKEN">As</span> <span class="TOKEN">String</span>
&nbsp;
<span class="REM">'Variablen f&uuml;r Dateizugriff (FSO)</span>
<span class="TOKEN">Dim</span> objFSO <span class="TOKEN">As</span> Object
<span class="TOKEN">Dim</span> objFolder <span class="TOKEN">As</span> Object
<span class="TOKEN">Dim</span> objFile <span class="TOKEN">As</span> Object
&nbsp;
<span class="REM">'Z&auml;hler und File f&uuml;r Pr&uuml;fung, ob Pings im Nirvana verschwunden sind</span>
<span class="TOKEN">Dim</span> lngCount <span class="TOKEN">As</span> <span class="TOKEN">Long</span>
<span class="TOKEN">Dim</span> objFileNirvana <span class="TOKEN">As</span> Object
&nbsp;
<span class="REM">'----------------------------------------------------------------------------------</span>
<span class="REM">'----------------------------------------------------------------------------------</span>
&nbsp;
&nbsp;
<span class="REM">'Systemzeit in Variable, damit einheitlich w&auml;hrend Ausf&uuml;hrung</span>
dtmIntervall = Now
&nbsp;
<span class="REM">'Ausf&uuml;hrungshinweis auf Button</span>
Tabelle1.cmdStart.Caption = &quot;Ping...&quot;
Application.Wait Now + TimeValue(&quot;00:00:01&quot;)
&nbsp;
<span class="REM">'Bereiche f&uuml;r PC-Namen und R&uuml;ckgabewerte ermitteln</span>
<span class="TOKEN">Set</span> rngPCs = Tabelle1.Range(&quot;A2:A&quot; &amp; Tabelle1.Range(&quot;A2&quot;).End(xlDown).Row)
<span class="REM">'Wenn keine PCs eingetragen sind ...</span>
<span class="TOKEN">If</span> rngPCs.Resize(1, 1) = &quot;&quot; <span class="TOKEN">Then</span>
<span class="REM"> '...Nachricht und abbrechen.</span>
MsgBox &quot;Kein PC eingetragen! Abbruch.&quot;, vbCritical
<span class="TOKEN">Exit Sub</span>
<span class="REM">'Wenn nur ein PC eingetragen, Bereich anpassen</span>
<span class="TOKEN">ElseIf</span> rngPCs.Resize(1, 1).Offset(1, 0) = &quot;&quot; <span class="TOKEN">Then</span>
<span class="TOKEN">Set</span> rngPCs = rngPCs.Resize(1, 1)
<span class="TOKEN">End</span> <span class="TOKEN">If</span>
<span class="REM">'Bereich f&uuml;r R&uuml;ckgabewerte ermitteln</span>
<span class="TOKEN">Set</span> rngAnAus = rngPCs.Offset(0, 1)
&nbsp;
<span class="REM">'Systemzeit in Tabellenkopf eintragen</span>
rngAnAus.Resize(1, 1).Offset(-1, 0) = Format(dtmIntervall, &quot;hh:mm:ss&quot;)
&nbsp;
<span class="REM">'FSO f&uuml;r Zugriff auf Dateien mit den R&uuml;ckgabewerten vorbereiten</span>
<span class="TOKEN">Set</span> objFSO = CreateObject(&quot;Scripting.FileSystemObject&quot;)
<span class="TOKEN">Set</span> objFolder = objFSO.GetFolder(&quot;C:\Pings&quot;)
&nbsp;
<span class="REM">'Alte Ausgabedateien l&ouml;schen</span>
<span class="TOKEN">For</span> <span class="TOKEN">Each</span> objFile <span class="TOKEN">In</span> objFolder.Files
Kill objFile.Path
<span class="TOKEN">Next</span> <span class="REM">'objFile</span>
&nbsp;
<span class="REM">'Pro PC eine Ausgabedatei erstellen</span>
<span class="TOKEN">For</span> <span class="TOKEN">Each</span> rng <span class="TOKEN">In</span> rngPCs
objFolder.CreateTextFile rng &amp; &quot;.txt&quot;
<span class="TOKEN">Next</span> <span class="REM">'rng</span>
&nbsp;
<span class="REM">'PCs anpingen und R&uuml;ckgabewert in Ausgabedatei umleiten</span>
<span class="TOKEN">For</span> <span class="TOKEN">Each</span> rng <span class="TOKEN">In</span> rngPCs
Shell &quot;cmd.exe /C Ping &quot; &amp; rng &amp; &quot; &gt;C:\Pings\&quot; &amp; rng &amp; &quot;.txt&quot;, vbHide
<span class="TOKEN">Next</span> <span class="REM">'rng</span>
&nbsp;
<span class="REM">'Solange Ausgabedatei in Ordner vorhanden</span>
<span class="TOKEN">Do</span> <span class="TOKEN">While</span> objFolder.Files.Count &gt; 0
<span class="TOKEN">For</span> <span class="TOKEN">Each</span> objFile <span class="TOKEN">In</span> objFolder.Files
<span class="REM"> 'Wenn R&uuml;ckmeldung in Ausgabedatei</span>
<span class="TOKEN">If</span> objFile.Size &gt; 0 <span class="TOKEN">Then</span>
<span class="REM"> 'Ausgabedatei &ouml;ffnen und Inhalt einlesen</span>
intFF = FreeFile
<span class="TOKEN">Open</span> objFile.Path <span class="TOKEN">For</span> <span class="TOKEN">Input</span> <span class="TOKEN">As</span> #intFF
strPCan = <span class="TOKEN">Input</span>(LOF(intFF), #intFF)
<span class="TOKEN">Close</span> #intFF
&nbsp;
<span class="REM"> 'Wenn Ping erfolglos</span>
<span class="TOKEN">If</span> InStr(1, strPCan, &quot;100% Verlust&quot;) &gt; 0 <span class="TOKEN">Then</span>
<span class="REM"> 'Zeile f&uuml;r den PC suchen und Ergebnis eintragen</span>
<span class="TOKEN">For</span> <span class="TOKEN">Each</span> rng <span class="TOKEN">In</span> rngPCs
<span class="TOKEN">If</span> rng = Left(objFile.Name, Len(objFile.Name) - 4) <span class="TOKEN">Then</span>
rng.Offset(0, rngAnAus.Column - rngPCs.Column) = strPCan
<span class="TOKEN">Exit For</span>
<span class="TOKEN">End</span> <span class="TOKEN">If</span>
<span class="TOKEN">Next</span> <span class="REM">'rng</span>
<span class="REM"> 'Wenn Ping erfolgreich</span>
<span class="TOKEN">ElseIf</span> InStr(1, strPCan, &quot;Antwort von&quot;) &gt; 0 <span class="TOKEN">Then</span>
<span class="REM"> 'Zeile f&uuml;r den PC suchen und Ergebnis eintragen</span>
<span class="TOKEN">For</span> <span class="TOKEN">Each</span> rng <span class="TOKEN">In</span> rngPCs
<span class="TOKEN">If</span> rng = Left(objFile.Name, Len(objFile.Name) - 4) <span class="TOKEN">Then</span>
rng.Offset(0, rngAnAus.Column - rngPCs.Column) = strPCan
<span class="TOKEN">Exit For</span>
<span class="TOKEN">End</span> <span class="TOKEN">If</span>
<span class="TOKEN">Next</span> <span class="REM">'rng</span>
<span class="TOKEN">End</span> <span class="TOKEN">If</span>
<span class="REM"> 'Ausgabedatei l&ouml;schen</span>
<span class="TOKEN">Do</span>
<span class="TOKEN">On</span> <span class="TOKEN">Error</span> <span class="TOKEN">Resume</span> <span class="TOKEN">Next</span>
Kill objFile.Path
<span class="TOKEN">Loop</span> <span class="TOKEN">Until</span> Err.Number &gt; 0
<span class="TOKEN">End</span> <span class="TOKEN">If</span>
<span class="TOKEN">Next</span> <span class="REM">'objFile</span>
lngCount = lngCount + 1
<span class="TOKEN">If</span> lngCount Mod 100000 = 0 <span class="TOKEN">Then</span>
<span class="TOKEN">For</span> <span class="TOKEN">Each</span> objFileNirvana <span class="TOKEN">In</span> objFolder.Files
Shell &quot;cmd.exe /C Ping &quot; &amp; Left(objFileNirvana.Name, 8) _
&amp; &quot; &gt;C:\Pings\&quot; &amp; objFileNirvana.Name, vbHide
<span class="TOKEN">Next</span> <span class="REM">'objFileNirvana</span>
<span class="TOKEN">End</span> <span class="TOKEN">If</span>
<span class="TOKEN">Loop</span> <span class="REM">'Do While objFolder.Files.Count &gt; 0</span>
&nbsp;
<span class="REM">'Neue Spalte f&uuml;r n&auml;chste Ergebnisse</span>
<span class="TOKEN">If</span> Tabelle1.Range(&quot;A1&quot;) &lt;&gt; &quot;&quot; <span class="TOKEN">Then</span> rngAnAus.EntireColumn.Insert
&nbsp;
<span class="REM">'Ausf&uuml;hrungshinweis auf Button l&ouml;schen</span>
Tabelle1.cmdStart.Caption = &quot;Start&quot;
&nbsp;
<span class="REM">'Wenn Zeitintervall angegeben, Makro neu aufrufen</span>
<span class="TOKEN">If</span> Tabelle1.Range(&quot;A1&quot;) &lt;&gt; &quot;&quot; <span class="TOKEN">Then</span>
Application.OnTime dtmIntervall + Range(&quot;A1&quot;), &quot;Pingen&quot;
<span class="TOKEN">End</span> <span class="TOKEN">If</span>
&nbsp;
<span class="TOKEN">End</span> <span class="TOKEN">Sub</span>&nbsp;</pre></div>
Code eingefügt mit dem MOF Code Converter (http://www.ms-office-forum.net/forum/codeconverter.php)

Gruß Ingolf

_anton_
14.03.2009, 12:57
Hallo ,

noch eine Variante:
<span style="font-family: Courier New,FixedSys;"><br><span style="color: #0000CC;">Sub</span> ping() <br>&nbsp; <span style="color: #0000CC;">Dim</span> objWMIService <span style="color: #0000CC;">As Object</span>, i <span style="color: #0000CC;">As Double</span> &nbsp; &nbsp; <br>&nbsp; <span style="color: #0000CC;">Dim</span> colPings <span style="color: #0000CC;">As Object</span>, objPing <span style="color: #0000CC;">As Object</span> &nbsp; <br>&nbsp; <span style="color: #0000CC;">On Error Resume Next</span> &nbsp; &nbsp;<br>&nbsp; <span style="color: #0000CC;">Set</span> objWMIService = GetObject(&quot;winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2&quot;) &nbsp; <br><span style="color: #009900;"> &nbsp;'Spalte A durchlaufen(IP-Adressen oder Computernamen)</span><br>&nbsp; <span style="color: #0000CC;">For</span> i = 1 <span style="color: #0000CC;">To</span> Tabelle1.UsedRange.Rows.Count &nbsp; <br>&nbsp; &nbsp; <span style="color: #0000CC;">If</span> Cells(i, 1).Value &lt;&gt; &quot;&quot; <span style="color: #0000CC;">Then</span> &nbsp;<br>&nbsp; &nbsp; &nbsp; Application.StatusBar = Cells(i, 1).Value<br>&nbsp; &nbsp; &nbsp; <span style="color: #0000CC;">Set</span> colPings = objWMIService.ExecQuery _ <br>&nbsp; &nbsp; &nbsp; &nbsp; (&quot;Select * From Win32_PingStatus where Address = '&quot; & Cells(i, 1).Text & &quot;'&quot;) <br>&nbsp; &nbsp; &nbsp; <span style="color: #0000CC;">If</span> Err = 0 <span style="color: #0000CC;">Then</span> &nbsp;<br>&nbsp; &nbsp; &nbsp; &nbsp; Err.Clear<br>&nbsp; &nbsp; &nbsp; &nbsp; <span style="color: #0000CC;">For Each</span> objPing <span style="color: #0000CC;">In</span> colPings &nbsp; <br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; <span style="color: #0000CC;">If</span> Err = 0 <span style="color: #0000CC;">Then</span> &nbsp;<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; Err.Clear<br><span style="color: #009900;"> &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;'in Spalte B Ergebniss schreiben</span><br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; <span style="color: #0000CC;">If</span> objPing.StatusCode = 0 <span style="color: #0000CC;">Then</span> &nbsp;<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; Cells(i, 2).Value = &quot;Timeout &quot; & objPing.ResponseTime & &quot; ms&quot;<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; Cells(i, 2).Interior.ColorIndex = 4 &nbsp;<span style="color: #009900;">'erreichbar = grün</span><br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; <span style="color: #0000CC;">Else</span> <br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; Cells(i, 2).Value = &quot;nicht erreichbar&quot;<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; Cells(i, 2).Interior.ColorIndex = 3 &nbsp;<span style="color: #009900;">'nicht erreichbar = rot</span><br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; <span style="color: #0000CC;">End If</span> &nbsp;<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; <span style="color: #0000CC;">End If</span> &nbsp;<br>&nbsp; &nbsp; &nbsp; &nbsp; <span style="color: #0000CC;">Next</span> <br>&nbsp; &nbsp; &nbsp; <span style="color: #0000CC;">Else</span> <br>&nbsp; &nbsp; &nbsp; &nbsp; Err.Clear<br>&nbsp; &nbsp; &nbsp; <span style="color: #0000CC;">End If</span> &nbsp;<br>&nbsp; &nbsp; <span style="color: #0000CC;">End If</span> &nbsp;<br>&nbsp; <span style="color: #0000CC;">Next</span> <br>&nbsp; Application.StatusBar = <span style="color: #0000CC;">False</span> <br><span style="color: #0000CC;">End Sub</span> &nbsp;<br><br></span>
mfg Anton

TobiasKornmayer
16.03.2009, 10:16
Hi Anton,
habe Deinen Ansatz getestet, aber colPings ändert seinen Status eigentlich nie, das heißt es geht irgendwie nich. Was hab ich falsch gemacht? Und wie funktioniert die Zeile Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")?

Lieber Gruß,
Tobias

TobiasKornmayer
16.03.2009, 14:34
Ah sorry, hatte den Verweis auf "Tabelle1" im Schleifenkopf nich bemerkt. Klappt bestens Dein Makro, vielen Dank. Wenn jemand interessiert ist, kann ich gern meine Arbeitsmappe mit den andern Ansätzen posten.

Lieber Gruß,
Tobias

Schnaggelz
08.02.2016, 16:19
Hey - das funzt richtig Gut, da kann ich die von mir zusammengeschusterte "sch.." eigentlich löschen..

Dies blockiert bei mehreren IP's den Rechner.. :(
Oberer SUB löscht nur den Inhalt - restliches Pingt (1x) und erzeugt ein On oder Offline..

Leider finde ich keine gescheite Lösung das CMD Fenster in den Hintergrund zu setzen innerhalb des Makros,.. und bei Eingabe des Rechnernamens wäre ein Drittes Feld mit IP recht schickt^^


Sub Clear()
'resetvalues
Rows("6:5124").Select
Selection.Clear
Rows("6:6").Select
End Sub
Sub RunPing()
i = 6
While (ActiveSheet.Cells(i, 1) <> "")
'Retrive IP address
strCompAddress = ActiveSheet.Cells(i, 1)

'//Setup shell command for Ping
Dim strShellCommand As String
strShellCommand = "C:\Windows\System32\PING.EXE -n 1 " + strCompAddress

'//create Shell Objekt in to run Scripts
Set osh = CreateObject("WScript.shell")
Set oEx = osh.Exec(strShellCommand)

'//Read output buffer
strBuf = oEx.StdOut.ReadAll
ActiveSheet.Cells(i, 2) = strBuf

Dim T
T = Split(strBuf, Chr(10))
If UBound(T) > 4 Then ActiveSheet.Cells(i, 2) = "Online" Else: ActiveSheet.Cells(i, 2) = "Offline"

i = i + 1
Wend
End Sub