Untitled

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