Public Class net_ping
 
    Private Declare Function GetHostByName Lib "wsock32.dll" Alias "gethostbyname" (ByVal Hostname As String) As Integer
    'UPGRADE_WARNING: Für die Struktur WSAdata müssen Marshalling-Attribute möglicherweise als ein Argument in dieser Declare-Anweisung weitergegeben werden. Klicken Sie hier für weitere Informationen: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"'
    Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired As Integer, ByRef lpWSAdata As WSAdata) As Integer
    Private Declare Function WSACleanup Lib "wsock32.dll" () As Integer
    'UPGRADE_ISSUE: Das Deklarieren eines Parameters als ''As Any'' wird nicht unterstützt. Klicken Sie hier für weitere Informationen: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="FAE78A8D-8978-4FD4-8208-5B7324A8F795"'
    'UPGRADE_ISSUE: Das Deklarieren eines Parameters als ''As Any'' wird nicht unterstützt. Klicken Sie hier für weitere Informationen: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="FAE78A8D-8978-4FD4-8208-5B7324A8F795"'
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef hpvDest As Object, ByRef hpvSource As Object, ByVal cbCopy As Integer)
    Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Integer
    Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal HANDLE As Integer) As Boolean
    'UPGRADE_WARNING: Für die Struktur IP_ECHO_REPLY müssen Marshalling-Attribute möglicherweise als ein Argument in dieser Declare-Anweisung weitergegeben werden. Klicken Sie hier für weitere Informationen: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"'
    'UPGRADE_WARNING: Für die Struktur IP_OPTION_INFORMATION müssen Marshalling-Attribute möglicherweise als ein Argument in dieser Declare-Anweisung weitergegeben werden. Klicken Sie hier für weitere Informationen: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"'
    Private Declare Function IcmpSendEcho Lib "ICMP" (ByVal IcmpHandle As Integer, ByVal DestAddress As Integer, ByVal RequestData As String, ByVal RequestSize As Short, ByRef RequestOptns As IP_OPTION_INFORMATION, ByRef ReplyBuffer As IP_ECHO_REPLY, ByVal ReplySize As Integer, ByVal TimeOut As Integer) As Boolean
    Private Structure WSAdata
        Dim wVersion As Short
        Dim wHighVersion As Short
        <vbfixedarray (255)> Dim szDescription() As Byte
        </vbfixedarray><vbfixedarray (128)> Dim szSystemStatus() As Byte
        Dim iMaxSockets As Short
        Dim iMaxUdpDg As Short
        Dim lpVendorInfo As Integer
 
        'UPGRADE_TODO: Zum Initialisieren der Instanzen dieser Struktur muss "Initialize" aufgerufen werden. Klicken Sie hier für weitere Informationen: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="B4BFF9E0-8631-45CF-910E-62AB3970F27B"'
        Public Sub Initialize()
            ReDim szDescription(255)
            ReDim szSystemStatus(128)
        End Sub
    End Structure
 
    Private Structure Hostent
        Dim h_name As Integer
        Dim h_aliases As Integer
        Dim h_addrtype As Short
        Dim h_length As Short
        Dim h_addr_list As Integer
    End Structure
 
    Private Structure IP_OPTION_INFORMATION
        Dim TTL As Byte
        Dim Tos As Byte
        Dim Flags As Byte
        Dim OptionsSize As Integer
        'UPGRADE_WARNING: Die Größe der Zeichenfolge mit fester Länge darf die Puffergröße nicht überschreiten. Klicken Sie hier für weitere Informationen: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="3C1E4426-0B80-443E-B943-0627CD55D48B"'
        <vbfixedstring (128), System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValArray, SizeConst:=128)> Public OptionsData() As Char
    End Structure
 
    Private Structure IP_ECHO_REPLY
        <vbfixedarray (3)> Dim Address() As Byte
        Dim Status As Integer
        Dim RoundTripTime As Integer
        Dim DataSize As Short
        Dim Reserved As Short
        Dim data As Integer
        Dim Options As IP_OPTION_INFORMATION
 
        'UPGRADE_TODO: Zum Initialisieren der Instanzen dieser Struktur muss "Initialize" aufgerufen werden. Klicken Sie hier für weitere Informationen: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="B4BFF9E0-8631-45CF-910E-62AB3970F27B"'
        Public Sub Initialize()
            ReDim Address(3)
        End Sub
    End Structure
 
    Private Const SOCKET_ERROR As Short = 0
 
    Public Function Ping(ByVal Server As String) As Integer
        'UPGRADE_WARNING: Arrays in Struktur lpWSAdata müssen möglicherweise initialisiert werden, bevor sie verwendet werden können. Klicken Sie hier für weitere Informationen: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="814DF224-76BD-4BB4-BFFB-EA359CB9FC48"'
        Dim hFile As Integer
        Dim lpWSAdata As WSAdata
        Dim hHostent As Hostent
        Dim AddrList As Integer
        Dim Address As Integer
        Dim rIP As String
        Dim OptInfo As IP_OPTION_INFORMATION
        'UPGRADE_WARNING: Arrays in Struktur EchoReply müssen möglicherweise initialisiert werden, bevor sie verwendet werden können. Klicken Sie hier für weitere Informationen: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="814DF224-76BD-4BB4-BFFB-EA359CB9FC48"'
        Dim EchoReply As IP_ECHO_REPLY
        Dim Hostname As String
 
        Ping = 0 'Rückgabe anfangs auf null setzen
        'If Left(Server, 7) = "http://" Then Server = Mid(Server, 8) 'http:// entfernen
 
        Call WSAStartup(&H101, lpWSAdata)
 
        If GetHostByName(Server & New String(Chr(0), 64 - Len(Server))) <> SOCKET_ERROR Then
            CopyMemory(hHostent.h_name, GetHostByName(Server & New String(Chr(0), 64 - Len(Server))), Len(hHostent))
            CopyMemory(AddrList, hHostent.h_addr_list, 4)
            CopyMemory(Address, AddrList, 4)
        End If
 
        hFile = IcmpCreateFile()
        If hFile = 0 Then Exit Function 'Bei Fehler abbrechen
 
        OptInfo.TTL = 255
 
        'Ping senden
        If IcmpSendEcho(hFile, Address, New String("A", 32), 32, OptInfo, EchoReply, Len(EchoReply) + 8, 2000) Then
            rIP = CStr(EchoReply.Address(0)) & "." & CStr(EchoReply.Address(1)) & "." & CStr(EchoReply.Address(2)) & "." & CStr(EchoReply.Address(3))
        Else
            'Fehler aufgetreten
            Exit Function
        End If
 
        If EchoReply.Status = 0 Then
            Ping = EchoReply.RoundTripTime
        Else
            'Keine Antwort bekommen
        End If
    End Function
 
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        Dim reply As Integer = Ping("google.com")
 
        If reply > 0 Then
            MessageBox.Show("Server antwortet:" & reply & " ms", "Erfolg", MessageBoxButtons.OK, MessageBoxIcon.Information)
        Else
            MessageBox.Show("Fehler beim Pingen", "Fehler", MessageBoxButtons.OK, MessageBoxIcon.Error)
        End If
 
    End Sub
End Class
 
 
</vbfixedarray></vbfixedstring></vbfixedarray>