Zurück zur Homepage

Tracert

Den Code im Beispiel 34 Ping absetzen kann man so umfunktionieren, dass er eine Route im Internet bis zum Ziel verfolgt. Man macht sich dabei zunutze, dass ein Paket verworfen wird, wenn der (Time to live) TTL-Zähler Null ist. Bei jedem Hop wird dieser um 1 verringert, um zu verhindern, dass ein Paket bei einem Fehler unbegrenzt im Netz kreisen kann. Schickt man nun einen Ping an ein Ziel ab und hat vorher den TTL-Zähler auf 1 gesetzt, sollte das Paket am ersten Hop verworfen und der Sender informiert werden. Dann kann man den Zähler auf 2 setzen und erneut einen Ping absetzen. Das macht man solange, bis das Ziel erreicht ist.

Beispieldatei (tracert.zip 39 KB)

###########################################
'# Ein KBlatt mit dem Namen IP-Adressen, welches in
'# Spalte A ab Zeile 2 die Zieladressen aufnimmt.
'# Ein Blatt mit Namen Auswertung, welches die
'# Ergebnisse aufnimmt.
'# Folgenden Code in ein Modul
'###########################################

 

Public Sub MyTrace()
Dim i As Long, Ziel As String
Dim k As Byte, aktZeile As Long
Dim a As New clsTracert
i = 2: aktZeile = 2
With Worksheets("Auswertung")
    .Range("A2:IV65000").ClearContents
    Do While Worksheets("IP-Adressen").Cells(i, 1).Value <> ""
        Ziel = Worksheets("IP-Adressen").Cells(i, 1).Value
        a.Zielhost = Ziel
        k = 250
        Application.StatusBar = "Ping ausführen nach " _
            & a.Zielhost
        .Cells(aktZeile, 1) = "Host"
        .Cells(aktZeile, 2) = a.Zielhost
        .Cells(aktZeile + 1, 1) = "IP"
        .Cells(aktZeile + 1, 2) = a.ZielIP
        a.tracert
        .Cells(aktZeile + 2, 1) = "Ping (ms)"
        If a.CurRetTime < 1000000 Then
            .Cells(aktZeile + 2, 2) = a.CurRetTime
        Else
            .Cells(aktZeile + 2, 2) = "Timeout"
        End If
        k = 1
        Do
            Application.StatusBar = "Tracerroute Hop #" & k
            a.Hop = k: a.tracert
            .Cells(aktZeile, k + 2) = a.CurHost
            .Cells(aktZeile + 1, k + 2) = a.CurIP
            If a.CurRetTime < 1000000 Then
                .Cells(aktZeile + 2, k + 2) = a.CurRetTime
            Else
                .Cells(aktZeile + 2, k + 2) = "Timeout"
            End If
            k = k + 1
        Loop While a.CurIP <> a.ZielIP
        i = i + 1: aktZeile = aktZeile + 3
    Loop
End With
Application.StatusBar = False
End Sub


 

'###########################################
'# Ein Klassenmodul mit dem Namen clsTracert
'###########################################

Option Explicit
Private Const MIN_SOCKETS_REQD As Long = 1
Private Const SOCKET_ERROR As Long = -1
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128
Private Const AF_INET As Long = 2
Private Type Hostent

    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLen As Integer
    hAddrList As Long

End Type


Private Type WSAdata

    wVersion As Integer
    wHighVersion As Integer
    szDescription(0 To MAX_WSADescription) As Byte
    szSystemStatus(0 To MAX_WSASYSStatus) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo 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
    ReturnedData As String * 256

End Type


Private Declare Sub CopyMemory _
    Lib "kernel32" Alias "RtlMoveMemory" _
    (hpvDest As Any, _
    ByVal hpvSource As Long, _
    ByVal cbCopy As Long)


Private Declare Function lstrcpy _
    Lib "kernel32" Alias "lstrcpyA" _
    (ByVal lpString1 As String, _
    ByVal lpString2 As Long) As Long


Private Declare Function gethostbyaddr _
    Lib "wsock32" _
    (szHost As Any, _
    ByVal dwHostLen As Integer, _
    dwSocketType As Integer) As Long


Private Declare Function GetHostByName _
    Lib "wsock32.dll" Alias "gethostbyname" _
    (ByVal Hostname As String) As Long


Private Declare Function WSAStartup _
    Lib "wsock32" _
    (ByVal wVersionRequired As Long, _
    lpWSAdata As WSAdata) As Long


Private Declare Function WSACleanup _
    Lib "wsock32.dll" _
    () As Long


Private Declare Function inet_addr _
    Lib "wsock32" _
    (ByVal cp As String) As Long


Private Declare Function inet_ntoa _
    Lib "wsock32" (ByVal in_addr As Long) _
    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


Private Type LngIP

    LngIP As Long
End Type


Private Type IP

    Byte4 As Byte
    Byte3 As Byte
    Byte2 As Byte
    Byte1 As Byte

End Type


Private myEcho As IP_ECHO_REPLY
Private iZielhost As String
Private iIPZielhost As String
Private iHop As Byte
Private iCurIP As String
Private iCurHost As String
Private iCurRetTime As Long
Private iMeldung As String
Private iTimeout As Long


Public Sub tracert()

iZielhost = Hostname_von_IP(iIPZielhost)
iIPZielhost = iZielhost
Lng_IP_von_Hostname iIPZielhost
With myEcho
    VbaPingen iZielhost, myEcho, iHop, iTimeout
    iCurIP = CStr(.Address(0)) & "." & _
        CStr(.Address(1)) & "." & _
        CStr(.Address(2)) & "." & _
        CStr(.Address(3))
    iCurHost = Hostname_von_IP(iCurIP)
    iCurRetTime = .RoundTripTime
    iMeldung = "Zielhost : " & iZielhost
    iMeldung = iMeldung & vbCrLf & "ZielIP : " & iIPZielhost
    iMeldung = iMeldung & vbCrLf & "CurHop : " & iZielhost
    iMeldung = iMeldung & vbCrLf & "CurIP : " & iCurIP
    iMeldung = iMeldung & vbCrLf & "CurHost : " & iCurHost
    iMeldung = iMeldung & vbCrLf & "CurTime : " & CStr(iCurRetTime)
End With
End Sub


Private Function VbaPingen(ByVal Hostname As String, myEcho As IP_ECHO_REPLY, Optional ttl As Byte, Optional Timeout As Long) As Long
Dim hlngFile As Long
Dim OptInfo As IP_OPTION_INFORMATION
Dim EchoReply As IP_ECHO_REPLY
Dim LngHostIP As Long
Dim strRequestData As String
Dim lngTimeout As Long
'Timeout festlegen
If Timeout = 0 Then
    lngTimeout = 6000
Else
    lngTimeout = Timeout
End If
'Time to Life festsetzen
OptInfo.ttl = 255
If ttl Then OptInfo.ttl = ttl
'Hostname nach Long umwandeln
LngHostIP = Lng_IP_von_Hostname(Hostname)
'Wenn Hostname eine IP ist, dann so
If LngHostIP = 0 Then LngHostIP = Lng_IP_von_IP(Hostname)
'Socket Initialisieren
If Not Initialisierung() Then Exit Function
'Datenblock erzeugen, der gesendet wird
strRequestData = String(32, "x")
'ICMP Filehandle besorgen
hlngFile = IcmpCreateFile()
'Ping absetzen
If IcmpSendEcho(hlngFile, LngHostIP, _
    strRequestData, Len(strRequestData), _
    OptInfo, myEcho, Len(myEcho) + 8, _
    lngTimeout) Then
    'Dauer zurückgeben
'    VbaPingen = myEcho.RoundTripTime
End If
'Etwas Zeit zum Verschnaufen lassen
DoEvents
'ICMP Filehandle schließen
IcmpCloseHandle hlngFile
WSACleanup
End Function


Private Function Initialisierung() As Boolean

Dim udtWSAData As WSAdata
'Socket Initialisieren
If WSAStartup(MIN_SOCKETS_REQD, udtWSAData) = SOCKET_ERROR Then
    Initialisierung = False
    Exit Function
End If
Initialisierung = True
End Function


Private Function IPString_von_IP_Long(IP As Long) As String

Dim ipPtr As Long
'Aus einer IP-Adresse Long eine gewohnte IP-Adresse
'machen

ipPtr = inet_ntoa(IP)
IPString_von_IP_Long = String(16, 0)
lstrcpy IPString_von_IP_Long, ipPtr
IPString_von_IP_Long = Left$(IPString_von_IP_Long, _
    InStr(1, IPString_von_IP_Long, Chr(0)))
End Function
Private Function Lng_IP_von_IP(ByVal strIP As String) As Long
Dim IP As IP, LIP As LngIP
'Aus einer gewohnten IP-Adresse ein Long machen
On Error Resume Next
    IP.Byte4 = CLng(Left$(strIP, InStr(1, strIP, ".") - 1))
    strIP = Right$(strIP, Len(strIP) - InStr(1, strIP, "."))
    IP.Byte3 = CLng(Left$(strIP, InStr(1, strIP, ".") - 1))
    strIP = Right$(strIP, Len(strIP) - InStr(1, strIP, "."))
    IP.Byte2 = CLng(Left$(strIP, InStr(1, strIP, ".") - 1))
    strIP = Right$(strIP, Len(strIP) - InStr(1, strIP, "."))
    IP.Byte1 = CLng(strIP)
    LSet LIP = IP
    Lng_IP_von_IP = LIP.LngIP
End Function


Private Function Lng_IP_von_Hostname(Hoststring As String) As Long

'Wenn Hoststring als Referenz übergeben wurde, dann
'wird die IP als Variable Hoststring in gewohnter Notation
'zurückgegeben (192.168.100.2)

Dim strHostname As String * 256
Dim lp_to_Hostent As Long
Dim IP_von_Hostname As String
Dim udtHost As Hostent
Dim LngIP As Long
Dim buffer(1 To 4) As Byte
Dim a As Long
On Error Resume Next
'Socket Initialisieren
If Not Initialisierung() Then Exit Function
'Nullchar anhängen
strHostname = Hoststring & vbNullChar
Hoststring = ""
'Pointer auf eine Hostsentstruktur ermitteln
lp_to_Hostent = GetHostByName(strHostname)
If lp_to_Hostent = 0 Then
    WSACleanup
    Exit Function
End If
With udtHost
    'Aus dem Speicher in eine Hostsentstruktur
    'kopieren

    CopyMemory udtHost, lp_to_Hostent, Len(udtHost)
    'Pointer auf die Adresse ermitteln
    CopyMemory LngIP, .hAddrList, 4
    'In ein Datenfeld kopieren
    CopyMemory buffer(1), LngIP, 4
    'Gleichzeitig in ein Long kopieren
    CopyMemory Lng_IP_von_Hostname, LngIP, 4
    'Aus dem Datenfeld in einen String
    For a = 1 To 4
        Hoststring = Hoststring _
            & buffer(a) & "."
    Next
    Hoststring = Left$(Hoststring, Len(Hoststring) - 1)
End With
WSACleanup
End Function


Private Function Hostname_von_IP(ByVal IP_String As String) _
    As String

'Aus einer IP in gewohnter Notation (192.168.100.5)
'wird der Hostname ermittelt

Dim lngNetwByteOrder As Long
Dim lp_to_Hostent As Long
Dim udtHost As Hostent
Hostname_von_IP = IP_String
Dim buffer(1 To 4) As Byte
    'Socket Initialisieren
    If Not Initialisierung() Then Exit Function
    'IP In Long umwandeln
    lngNetwByteOrder = inet_addr(IP_String)
    'In einen Buffer kopieren
    CopyMemory buffer(1), VarPtr(lngNetwByteOrder), 4
    'Pointer auf eine Hostsentstruktur ermitteln
    lp_to_Hostent = gethostbyaddr(buffer(1), 4, AF_INET)
    If lp_to_Hostent = 0 Then WSACleanup: Exit Function
    'Aus dem Speicher in eine Hostsentstruktur
    'kopieren

    CopyMemory udtHost, lp_to_Hostent, Len(udtHost)
    'Buffer bereitstellen
    Hostname_von_IP = String(256, 0)
    'Name in Buffer kopieren
    CopyMemory ByVal Hostname_von_IP, udtHost.hName, 255
    'Nullchars abschneiden
    Hostname_von_IP = Left$(Hostname_von_IP, _
        InStr(1, Hostname_von_IP, vbNullChar) - 1)
    WSACleanup
End Function


Public Function Convert_IP_To_Host(IP As String) As String

    Convert_IP_To_Host = Hostname_von_IP(IP)
End Function


Public Function Convert_Host_To_IP(Host As String) As String

    Convert_Host_To_IP = Host
    Lng_IP_von_Hostname Convert_Host_To_IP
End Function


Public Function Convert_Long_To_IP(IP As String) As String

    Convert_Long_To_IP = IPString_von_IP_Long(IP)
End Function


Public Property Get CurIP() As String

    CurIP = iCurIP
End Property


Public Property Get CurHost() As String

    CurHost = iCurHost
End Property


Public Property Get CurRetTime() As Long

    CurRetTime = iCurRetTime
End Property


Public Property Get Timeout() As Long

    Timeout = iTimeout
End Property
Public Property Let Timeout(ByVal vNewValue As Long)

    iTimeout = vNewValue
End Property


Public Property Get Hop() As Byte

    Hop = iHop
End Property
Public Property Let Hop(ByVal vNewValue As Byte)

    iHop = vNewValue
End Property


Public Property Get ZielIP() As String

    ZielIP = iIPZielhost
End Property
Public Property Let ZielIP(ByVal vNewValue As String)

    iZielhost = Hostname_von_IP(vNewValue)
    iIPZielhost = iZielhost
    Lng_IP_von_Hostname iIPZielhost
End Property


Public Property Get Zielhost() As String

    Zielhost = iZielhost
End Property
Public Property Let Zielhost(ByVal vNewValue As String)

    iZielhost = Hostname_von_IP(vNewValue)
    iIPZielhost = iZielhost
    Lng_IP_von_Hostname iIPZielhost
End Property