'------------------- Anfang Code Module1  -------------------
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"Alias _
        "WSACleanup" () As Long
 
Private Declare Function GetHostName Lib "wsock32.dll"Alias _
        "gethostname" (ByVal szHost As String, ByVal dwHostLen _
        As Long) As Long
 
Private Declare Function GetHostByName Lib "wsock32.dll"Alias _
        "gethostbyname" (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
 
Const MAX_WSADescription = 256
Const MAX_WSASYSStatus = 128
Const MAXGETHOSTSTRUCT = 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
 
Const IP_STATUS_BASE = 11000
Const IP_SUCCESS = 0
Const IP_BUF_TOO_SMALL = (11000 + 1)
Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
Const IP_NO_RESOURCES = (11000 + 6)
Const IP_BAD_OPTION = (11000 + 7)
Const IP_HW_ERROR = (11000 + 8)
Const IP_PACKET_TOO_BIG = (11000 + 9)
Const IP_REQ_TIMED_OUT = (11000 + 10)
Const IP_BAD_REQ = (11000 + 11)
Const IP_BAD_ROUTE = (11000 + 12)
Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
Const IP_PARAM_PROBLEM = (11000 + 15)
Const IP_SOURCE_QUENCH = (11000 + 16)
Const IP_OPTION_TOO_BIG = (11000 + 17)
Const IP_BAD_DESTINATION = (11000 + 18)
Const IP_ADDR_DELETED = (11000 + 19)
Const IP_SPEC_MTU_CHANGE = (11000 + 20)
Const IP_MTU_CHANGE = (11000 + 21)
Const IP_UNLOAD = (11000 + 22)
Const IP_ADDR_ADDED = (11000 + 23)
Const IP_GENERAL_FAILURE = (11000 + 50)
Const MAX_IP_STATUS = 11000 + 50
Const IP_PENDING = (11000 + 255)
Const PING_TIMEOUT = 200
Const WS_VERSION_REQD = &H101
Const WS_VERSION_MAJOR = WS_VERSION_REQD  &H100 And &HFF&
Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Const MIN_SOCKETS_REQD = 1
Const SOCKET_ERROR = -1
Const INADDR_NONE = &HFFFFFFFF
 
'Variablen:
'==========
 
Public Const hostent_size = 16
Public PointerToPointer, IPLong As Long
 
Dim hostent_async As hostent_async
Dim ICMPOPT As ICMP_OPTIONS
 
Public Function GetHost(ByVal Host$) As Long
  Dim ListAddress As Long
  Dim ListAddr As Long
  Dim LH&, phe&
  Dim Start As Boolean
  Dim heDestHost As hostent
  Dim addrList&, repIP&
 
    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
 
    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 Code Module1  --------------------
 
'-------------------- Anfang Code Form1  --------------------
'Autor: Stefan Moosbauer
'Email: 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
End Sub
'--------------------- Ende Code Form1  ---------------------