Startseite / Tipps / VB 5/6-Tipp 0329: Einen Server anpingen

VB 5/6-Tipp 0329: Einen Server anpingen

 von Stefan Moosbauer

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Textfeld "Text1" (Index von 0 bis 6)
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Textfeld "Text4" auf Frame1
' Steuerelement: Textfeld "Text3" auf Frame1
' Steuerelement: Textfeld "Text2" auf Frame1
' Steuerelement: Schaltfläche "Command1" auf Frame1
' Steuerelement: Beschriftungsfeld "Label10" auf Frame1
' Steuerelement: Beschriftungsfeld "Label9" auf Frame1
' Steuerelement: Beschriftungsfeld "Label8" auf Frame1
' Steuerelement: Beschriftungsfeld "Label7" auf Frame1
' Steuerelement: Beschriftungsfeld "Label6" auf Frame1
' Steuerelement: Beschriftungsfeld "Label5" auf Frame1
' Steuerelement: Beschriftungsfeld "Label4" auf Frame1
' Steuerelement: Beschriftungsfeld "Label3" auf Frame1
' Steuerelement: Beschriftungsfeld "Label2" auf Frame1
' Steuerelement: Beschriftungsfeld "Label1" auf Frame1


'Autor: Stefan Moosbauer
'E-Mail: stefan.moosbauer@aon.at

Option Explicit

Private Sub Command1_Click()
    Dim ECHO As ICMP_ECHO_REPLY
    Dim pos As Integer
   
    'Die Ping-Funktion aufrufen:
    Call Ping(Trim$(Text2.Text), ECHO)
    
    'Ergebnisse anzeigen
    Text1(0) = GetStatusCode(ECHO.Status)
    Text1(1) = ECHO.Address
    Text1(2) = ECHO.RoundTripTime & " ms"
    Text1(3) = ECHO.DataSize & " bytes"
    
    If Left$(ECHO.Data, 1) <> Chr$(0) Then
        pos = InStr(ECHO.Data, Chr$(0))
        Text1(4) = Left$(ECHO.Data, pos - 1)
    End If
    
    Text1(5) = ECHO.DataPointer
    Text1(6) = ECHO.Options.Ttl
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------

Option Explicit

Private Declare Function IcmpCreateFile Lib "icmp.dll" () _
        As Long

Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal _
        IcmpHandle As Long) As Long
   
Private Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal _
        IcmpHandle As Long, ByVal DestinationAddress As Long, _
        ByVal RequestData As String, ByVal RequestSize As _
        Integer, ByVal RequestOptions As Long, ReplyBuffer As _
        ICMP_ECHO_REPLY, ByVal ReplySize As Long, ByVal _
        TimeOut As Long) As Long
    
Private Declare Function WSAGetLastError Lib "wsock32.dll" () _
        As Long

Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal _
        wVersionRequired As Long, lpWSAData As WSAData) As Long
    
Private Declare Function WSACleanup Lib "wsock32.dll" _
        () As Long

Private Declare Function gethostname Lib "wsock32.dll" _
        (ByVal szHost As String, ByVal dwHostLen _
        As Long) As Long
    
Private Declare Function gethostbyname Lib "wsock32.dll" _
        (ByVal szHost As String) As Long
   
Private Declare Sub CopyMemory Lib "kernel32" Alias _
        "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As _
        Long, ByVal cbCopy As Long)

Private Declare Function htonl Lib "wsock32.dll" (ByVal hostlong _
        As Long) As Long
        
Private Declare Function htons Lib "wsock32.dll" (ByVal hostshort _
        As Long) As Integer
        
Private Declare Function inet_addr Lib "wsock32.dll" (ByVal cp _
        As String) As Long
        
Private Declare Function inet_ntoa Lib "wsock32.dll" (ByVal inn _
        As Long) As Long
        
Private Declare Function ntohl Lib "wsock32.dll" (ByVal netlong _
        As Long) As Long
        
Private Declare Function ntohs Lib "wsock32.dll" (ByVal netshort _
        As Long) As Integer
    
Private Type ICMP_OPTIONS
    Ttl As Byte
    Tos As Byte
    Flags As Byte
    OptionsSize As Byte
    OptionsData As Long
End Type

Public Type ICMP_ECHO_REPLY
    Address As Long
    Status As Long
    RoundTripTime As Long
    DataSize As Integer
    Reserved As Integer
    DataPointer As Long
    Options As ICMP_OPTIONS
    Data As String * 250
End Type

Private Type hostent
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLen As Integer
    hAddrList As Long
End Type

Private Const MAX_WSADescription As Long = 256&
Private Const MAX_WSASYSStatus As Long = 128&
Private Const MAXGETHOSTSTRUCT As Long = 1024&

Private Type WSAData
    wVersion As Integer
    wHighVersion As Integer
    szDescription(0 To MAX_WSADescription) As Byte
    szSystemStatus(0 To MAX_WSASYSStatus) As Byte
    wMaxSockets As Integer
    wMaxUDPDG As Integer
    dwVendorInfo As Long
End Type

Private Type hostent_async
    h_name As Long
    h_aliases As Long
    h_addrtype As Integer
    h_length As Integer
    h_addr_list As Long
    h_asyncbuffer(MAXGETHOSTSTRUCT) As Byte
End Type
    
Private Const IP_STATUS_BASE As Long = 11000&
Private Const IP_SUCCESS As Long = 0&
Private Const IP_BUF_TOO_SMALL As Long = (11000& + 1&)
Private Const IP_DEST_NET_UNREACHABLE As Long = (11000& + 2&)
Private Const IP_DEST_HOST_UNREACHABLE As Long = (11000& + 3&)
Private Const IP_DEST_PROT_UNREACHABLE As Long = (11000& + 4&)
Private Const IP_DEST_PORT_UNREACHABLE As Long = (11000& + 5&)
Private Const IP_NO_RESOURCES As Long = (11000& + 6&)
Private Const IP_BAD_OPTION As Long = (11000& + 7&)
Private Const IP_HW_ERROR As Long = (11000& + 8&)
Private Const IP_PACKET_TOO_BIG As Long = (11000& + 9&)
Private Const IP_REQ_TIMED_OUT As Long = (11000& + 10&)
Private Const IP_BAD_REQ As Long = (11000& + 11&)
Private Const IP_BAD_ROUTE As Long = (11000& + 12&)
Private Const IP_TTL_EXPIRED_TRANSIT As Long = (11000& + 13&)
Private Const IP_TTL_EXPIRED_REASSEM As Long = (11000& + 14&)
Private Const IP_PARAM_PROBLEM As Long = (11000& + 15&)
Private Const IP_SOURCE_QUENCH As Long = (11000& + 16&)
Private Const IP_OPTION_TOO_BIG As Long = (11000& + 17&)
Private Const IP_BAD_DESTINATION As Long = (11000& + 18&)
Private Const IP_ADDR_DELETED As Long = (11000& + 19&)
Private Const IP_SPEC_MTU_CHANGE As Long = (11000& + 20&)
Private Const IP_MTU_CHANGE As Long = (11000& + 21&)
Private Const IP_UNLOAD As Long = (11000& + 22&)
Private Const IP_ADDR_ADDED As Long = (11000& + 23&)
Private Const IP_GENERAL_FAILURE As Long = (11000& + 50&)
Private Const MAX_IP_STATUS As Long = 11000& + 50&
Private Const IP_PENDING As Long = (11000& + 255&)
Private Const PING_TIMEOUT As Long = 200&
Private Const WS_VERSION_REQD As Long = &H101&
Private Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100& And &HFF&
Private Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD As Long = 1&
Private Const SOCKET_ERROR As Long = -1&
Private Const INADDR_NONE As Long = &HFFFFFFFF

'Variablen:
'==========

Public Const hostent_size As Long = 16&
Public PointerToPointer As Long, IPLong As Long

Dim hostent_async As hostent_async
Dim ICMPOPT As ICMP_OPTIONS

Public Function GetHost(ByVal Host As String) As Long
    Dim ListAddress As Long
    Dim ListAddr As Long
    Dim LH As Long, phe As Long
    Dim Start As Boolean
    Dim heDestHost As hostent
    Dim addrList As Long, repIP As Long

    Start = SocketsInitialize
    If Start = False Then
        GetHost = 0
        MsgBox ("Fehler bei der SocketInitialisierung!")
        Exit Function
    End If

    LH = inet_addr(Host)
    repIP = LH
    If LH = INADDR_NONE Then
        phe = gethostbyname(Host)
        If phe <> 0 Then
            CopyMemory heDestHost, ByVal phe, hostent_size
            CopyMemory addrList, ByVal heDestHost.hAddrList, 4
            CopyMemory repIP, ByVal addrList, heDestHost.hLen
        Else
            Call MsgBox("GetHostByName lieferte ungültiges Ergebnis!")
            GetHost = INADDR_NONE
            Exit Function
        End If
    End If
    
    Form1.Text4.Text = CStr(repIP)
    GetHost = repIP
End Function

Public Function GetStatusCode(Status As Long) As String
    Dim Msg As String

    Select Case Status
        Case IP_SUCCESS:               Msg = "ip success"
        Case IP_BUF_TOO_SMALL:         Msg = "ip buf too_small"
        Case IP_DEST_NET_UNREACHABLE:  Msg = "ip dest net unreachable"
        Case IP_DEST_HOST_UNREACHABLE: Msg = "ip dest host unreachable"
        Case IP_DEST_PROT_UNREACHABLE: Msg = "ip dest prot unreachable"
        Case IP_DEST_PORT_UNREACHABLE: Msg = "ip dest port unreachable"
        Case IP_NO_RESOURCES:          Msg = "ip no resources"
        Case IP_BAD_OPTION:            Msg = "ip bad option"
        Case IP_HW_ERROR:              Msg = "ip hw_error"
        Case IP_PACKET_TOO_BIG:        Msg = "ip packet too_big"
        Case IP_REQ_TIMED_OUT:         Msg = "ip req timed out"
        Case IP_BAD_REQ:               Msg = "ip bad req"
        Case IP_BAD_ROUTE:             Msg = "ip bad route"
        Case IP_TTL_EXPIRED_TRANSIT:   Msg = "ip ttl expired transit"
        Case IP_TTL_EXPIRED_REASSEM:   Msg = "ip ttl expired reassem"
        Case IP_PARAM_PROBLEM:         Msg = "ip param_problem"
        Case IP_SOURCE_QUENCH:         Msg = "ip source quench"
        Case IP_OPTION_TOO_BIG:        Msg = "ip option too_big"
        Case IP_BAD_DESTINATION:       Msg = "ip bad destination"
        Case IP_ADDR_DELETED:          Msg = "ip addr deleted"
        Case IP_SPEC_MTU_CHANGE:       Msg = "ip spec mtu change"
        Case IP_MTU_CHANGE:            Msg = "ip mtu_change"
        Case IP_UNLOAD:                Msg = "ip unload"
        Case IP_ADDR_ADDED:            Msg = "ip addr added"
        Case IP_GENERAL_FAILURE:       Msg = "ip general failure"
        Case IP_PENDING:               Msg = "ip pending"
        Case PING_TIMEOUT:             Msg = "ping timeout"
        Case Else:                     Msg = "unknown  msg returned"
    End Select
   
    GetStatusCode = CStr(Status) & "   [ " & Msg & " ]"
End Function

Private Function HiByte(ByVal wParam As Integer)
    HiByte = wParam \ &H100 And &HFF&
End Function

Private Function LoByte(ByVal wParam As Integer)
    LoByte = wParam And &HFF&
End Function

Public Function Ping(szAddress As String, ECHO As ICMP_ECHO_REPLY) As Long
    Dim hPort As Long
    Dim dwAddress As Long
    Dim sDataToSend As String
    Dim iOpt As Long
    Dim a As String
   
    sDataToSend = Trim$(Form1.Text3.Text)
    dwAddress = GetHost(szAddress)
    
    hPort = IcmpCreateFile()
    
    If IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), _
                    0, ECHO, Len(ECHO), PING_TIMEOUT) Then
    
        Ping = ECHO.RoundTripTime
    Else
        Ping = ECHO.Status * -1
    End If
                        
    Call IcmpCloseHandle(hPort)
    a = SocketsCleanup
End Function
   
Private Function AddressStringToLong(ByVal Tmp As String) As Long
    Dim i As Integer
    Dim parts(1 To 4) As String
    
    i = 0
    While InStr(Tmp, ".") > 0
        i = i + 1
        parts(i) = Mid(Tmp, 1, InStr(Tmp, ".") - 1)
        Tmp = Mid(Tmp, InStr(Tmp, ".") + 1)
    Wend
    
    i = i + 1
    parts(i) = Tmp
    
    If i <> 4 Then
        AddressStringToLong = 0
        Exit Function
    End If
    
    AddressStringToLong = Val("&H" & Right("00" & Hex(parts(4)), 2) & _
        Right("00" & Hex(parts(3)), 2) & Right("00" & Hex(parts(2)), 2) & _
        Right("00" & Hex(parts(1)), 2))
End Function

Private Function SocketsCleanup() As Boolean
    Dim X As Long
    
    X = WSACleanup()
    If X <> 0 Then
        Call MsgBox("Windows Sockets error " & Trim$(Str$(X)) & _
            " occurred in Cleanup.", vbExclamation)
        
        SocketsCleanup = False
    Else
        SocketsCleanup = True
    End If
End Function

Private Function SocketsInitialize() As Boolean
    Dim WSAD As WSAData
    Dim X As Integer
    Dim szLoByte As String, szHiByte As String, szBuf As String
    
    X = WSAStartup(WS_VERSION_REQD, WSAD)
    If X <> 0 Then
        Call MsgBox("Windows Sockets for 32 bit Windows " & _
                  "environments is not successfully responding.")
        
        SocketsInitialize = False
        Exit Function
    End If
    
    SocketsInitialize = True
End Function
'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 26 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.