VB6 - Clean Ping in VB6 Code

[dilettante]

Here is version 2 of my PingIPv4.bas module. Version 1 was a little too feature-poor for publication.

There is a Ping() function that you pass an IP address string value to. There are optional arguments to set a non-default timeout in milliseconds or a string to be echoed as part of a larger payload. By default the timeout is 1000 and the data string is "".

In case you need name resolution you can call the helper function Resolve(). You pass a string containing either an IP address or network name (DNS, Hosts file, WINS, etc. host names) and it returns the IP adress string in the second argument. Then this "converted" string can be used with Ping() calls.


You can use this as-is, delete parts you don't need, expand upon it further, etc. (see the comments). You could also convert it to a Class which makes the code dynamic (i.e. if you only need to ping on occasion your program won't carry the baggage of a static module for its entire lifetime).

Tested on Windows 95 OSR2, Windows XP SP3, Windows Vista SP2, and Windows 7 SP1.

Atached here as part of a working demo Project.


While there is another example posted here somewhere it is pretty old and crusty. It also appears to have been hastily created from some really, really raggedy VB4 code he found somewhere.

[dilettante]

Here is a version 3 that takes care of wrapping the previous logic as a Class. It also exposes a RoundTripTime property instead of the entire ICMP_ECHO_REPLY structure (that is seldom needed anyway).

Remember, this is done with simple API calls. Thus you have none of the issues of the slow, clunky, heavyweight, and erratically available WMI Service - which was designed to support occasional admin scripting and not application logic. This works even where WMI doesn't exist at all, as well as where the Service has been disabled for security reasons.

[MatthiasMatthias]

I search an example do the same with ipv6.

[Calcu]

I know it's and old post, but still so useful.
Adapted the code to 64 bits (someone like me will use it in access64 for example)

Option Explicit
Private Const INADDR_NONE As Long = -1
Private Const INVALID_HANDLE_VALUE As Long = -1

Private Const WINSOCK_2_2 As Long = &H202&

#If VBA7 Then
    Private Const NULL_VALUE As LongPtr = 0
#Else
    Private Const NULL_VALUE As Long = 0
#End If

Public Enum PING_FAIL_REASONS
    PFR_NONE = 0
    PFR_BAD_IP
    PFR_ICMPCREATEFILE
    PFR_ICMPSENDECHO
    PFR_ICMPCLOSEHANDLE
End Enum
'Preserve case of these identifiers:
#If False Then
Dim PFR_NONE, PFR_ICMPCREATEFILE, PFR_ICMPSENDECHO, PFR_ICMPCLOSEHANDLE
#End If

Public Enum IP_STATUSES
    IP_SUCCESS = 0
    IP_BUF_TOO_SMALL = 11001
    IP_DEST_NET_UNREACHABLE = 11002
    IP_DEST_HOST_UNREACHABLE = 11003
    IP_DEST_PROT_UNREACHABLE = 11004
    IP_DEST_PORT_UNREACHABLE = 11005
    IP_NO_RESOURCES = 11006
    IP_BAD_OPTION = 11007
    IP_HW_ERROR = 11008
    IP_PACKET_TOO_BIG = 11009
    IP_REQ_TIMED_OUT = 11010
    IP_BAD_REQ = 11011
    IP_BAD_ROUTE = 11012
    IP_TTL_EXPIRED_TRANSIT = 11013
    IP_TTL_EXPIRED_REASSEM = 11014
    IP_PARAM_PROBLEM = 11015
    IP_SOURCE_QUENCH = 11016
    IP_OPTION_TOO_BIG = 11017
    IP_BAD_DESTINATION = 11018
    IP_GENERAL_FAILURE = 11050
End Enum
'Preserve case of these identifiers:
#If False Then
Dim IP_SUCCESS, IP_BUF_TOO_SMALL, IP_DEST_NET_UNREACHABLE, IP_DEST_HOST_UNREACHABLE
Dim IP_DEST_PROT_UNREACHABLE, IP_DEST_PORT_UNREACHABLE, IP_NO_RESOURCES, IP_BAD_OPTION
Dim IP_HW_ERROR, IP_PACKET_TOO_BIG, IP_REQ_TIMED_OUT, IP_BAD_REQ, IP_BAD_ROUTE
Dim IP_TTL_EXPIRED_TRANSIT, IP_TTL_EXPIRED_REASSEM, IP_PARAM_PROBLEM, IP_SOURCE_QUENCH
Dim IP_OPTION_TOO_BIG, IP_BAD_DESTINATION, IP_GENERAL_FAILURE
#End If

Public Enum RESOLVE_ERRORS
    RES_SUCCESS = 0
    RES_FORMATTING_ERR = 1
    WSAEINTR = 10004
    WSAEFAULT = 10014
    WSAEINPROGRESS = 10036
    WSAENETDOWN = 10050
    WSAEPROCLIM = 10067
    WSASYSNOTREADY = 10091
    WSAVERNOTSUPPORTED = 10092
    WSANOTINITIALISED = 10093
    WSAHOST_NOT_FOUND = 11001
    WSATRY_AGAIN = 11002
    WSANO_RECOVERY = 11003
    WSANO_DATA = 11004
End Enum
'Protect case of these identifiers:
#If False Then
Dim RES_SUCCESS, RES_FORMATTING_ERR, WSAEINTR, WSAEFAULT, WSAEINPROGRESS, WSAENETDOWN
Dim WSAEPROCLIM, WSASYSNOTREADY, WSAVERNOTSUPPORTED, WSANOTINITIALISED, WSAHOST_NOT_FOUND
Dim WSATRY_AGAIN, WSANO_RECOVERY, WSANO_DATA
#End If

Private Type hostent
    h_name As Long
    h_aliases As Long
    h_addrtype As Integer
    h_length As Integer
    h_addr_list As Long
End Type

Private Type WSAData
    wVersion As Integer
    wHighVersion As Integer
    szDescription(0 To 255) As Byte
    szSystemStatus(0 To 127) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type

#If VBA7 Then
    ' Para entornos de 64 bits
    Private Type IP_OPTION_INFORMATION
        Ttl As Byte
        Tos As Byte
        Flags As Byte
        OptionsSize As Byte
        OptionsData As LongPtr ' Cambiado a LongPtr para 64 bits.
    End Type

    Private Type ICMP_ECHO_REPLY
        Address As LongPtr ' Cambiado a LongPtr para 64 bits.
        Status As Long
        RoundTripTime As Long
        DataSize As Integer
        Reserved As Integer
        Data As LongPtr ' Cambiado a LongPtr para 64 bits.
        Options As IP_OPTION_INFORMATION
    End Type
#Else
    ' Para entornos de 32 bits
    Private Type IP_OPTION_INFORMATION
        Ttl As Byte
        Tos As Byte
        Flags As Byte
        OptionsSize As Byte
        OptionsData As Long
    End Type

    Private Type ICMP_ECHO_REPLY
        Address As Long
        Status As Long
        RoundTripTime As Long
        DataSize As Integer
        Reserved As Integer
        Data As Long
        Options As IP_OPTION_INFORMATION
    End Type
#End If

#If VBA7 Then
    'x64
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
    Private Declare PtrSafe Function gethostbyname Lib "wsock32" (ByVal name As String) As Long
    Private Declare PtrSafe Function IcmpCloseHandle Lib "Icmp" (ByVal IcmpHandle As LongPtr) As Long
    Private Declare PtrSafe Function IcmpCreateFile Lib "Icmp" () As LongPtr
    Private Declare PtrSafe Function IcmpSendEcho Lib "Icmp" (ByVal IcmpHandle As LongPtr, ByVal DestinationAddress As LongPtr, ByVal RequestData As String, ByVal RequestSize As Integer, ByVal RequestOptions As LongPtr, ByRef ReplyBuffer As Byte, ByVal ReplySize As Long, ByVal Timeout As Long) As Long
    Private Const Estoyen64 As Boolean = True
    Private Declare PtrSafe Function inet_addr Lib "wsock32" (ByVal cp As String) As Long
    Private Declare PtrSafe Function inet_ntoa Lib "wsock32" (ByVal inAddr As Long) As Long
    Private Declare PtrSafe Function lstrcpyn Lib "kernel32" Alias "lstrcpynA" (ByVal lpString1 As String, ByVal lpString2 As Long, ByVal iMaxLength As Long) As Long
    Private Declare PtrSafe Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
    Private Declare PtrSafe Function WSACleanup Lib "wsock32" () As Long
    Private Declare PtrSafe Function WSAStartup Lib "wsock32" (ByVal wVersionRequested As Integer, ByRef lpWSAData As WSAData) As Long
#Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
    Private Declare Function gethostbyname Lib "wsock32" (ByVal name As String) As Long
    Private Declare Function IcmpCloseHandle Lib "Icmp" (ByVal IcmpHandle As Long) As Long
    Private Declare Function IcmpCreateFile Lib "Icmp" () As Long
    Private Declare Function IcmpSendEcho Lib "Icmp" (ByVal IcmpHandle As Long, ByVal DestinationAddress As Long, ByVal RequestData As String, ByVal RequestSize As Integer, ByVal RequestOptions As Long, ByRef ReplyBuffer As Byte, ByVal ReplySize As Long, ByVal Timeout As Long) As Long
    Private Declare Function inet_addr Lib "wsock32" (ByVal cp As String) As Long
    Private Const Estoyen64 As Boolean = False
    'NULL_VALUE on failure, else pointer to IP string.
    Private Declare Function inet_ntoa Lib "wsock32" (ByVal inAddr As Long) As Long
    Private Declare Function lstrcpyn Lib "kernel32" Alias "lstrcpynA" (ByVal lpString1 As String, ByVal lpString2 As Long, ByVal iMaxLength As Long) As Long
    Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
    'Non-0 on failure, result is error number.
    Private Declare Function WSACleanup Lib "wsock32" () As Long
    'Non-0 on failure, result is error number.
    Private Declare Function WSAStartup Lib "wsock32" (ByVal wVersionRequested As Integer, ByRef lpWSAData As WSAData) As Long
#End If



Public Reason As PING_FAIL_REASONS 'When = PFR_ICMPSENDECHO, Status may have
                                   'IP_STATUSES values.
Public Status As IP_STATUSES       'May contain system error numbers or
                                   'IP_STATUSES values.
Public RoundTripTime As Long       'Milliseconds.

Public Function PingOK(ByVal ip As String, Optional ByVal TimeoutMS As Long = 1000, Optional ByVal Data As String = "") As Boolean
    'If Data is provided it is converted to ANSI by our Declare before being sent.
    
    Dim Reply As ICMP_ECHO_REPLY
    
    #If VBA7 Then
        Dim IPAddr As LongPtr
        Dim hIcmp As LongPtr
    #Else
        Dim IPAddr As Long
        Dim hIcmp As Long
    #End If
    
    Dim BufSize As Long
    Dim Buffer() As Byte
    Dim Replies As Long
    
    Status = 0
    
    IPAddr = inet_addr(ip)
    
    If IPAddr = INADDR_NONE Then
        Reason = PFR_BAD_IP
    Else
        hIcmp = IcmpCreateFile()
        If hIcmp = INVALID_HANDLE_VALUE Then
            Reason = PFR_ICMPCREATEFILE
            Status = Err.LastDllError
        Else
            If Estoyen64 Then
                BufSize = Len(Reply) + Len(Data) + 16
            Else
                BufSize = Len(Reply) + Len(Data) + 8
            End If
            
            ReDim Buffer(BufSize - 1)
          '  Replies = IcmpSendEcho(hIcmp, IPAddr, Data, Len(Data), NULL_VALUE, Buffer(0), BufSize, TimeoutMS)
            Replies = IcmpSendEcho(hIcmp, CLngPtr(IPAddr), Data, Len(Data), NULL_VALUE, Buffer(0), BufSize, TimeoutMS)

            If Replies = 0 Then
                Reason = PFR_ICMPSENDECHO
                Status = Err.LastDllError
            Else
                CopyMemory Reply, Buffer(0), Len(Reply)
                RoundTripTime = Reply.RoundTripTime
                PingOK = True
            End If
            If IcmpCloseHandle(hIcmp) = 0 Then
                PingOK = False
                Reason = PFR_ICMPCLOSEHANDLE
                Status = Err.LastDllError
            End If
        End If
    End If
End Function

Public Function Resolve(ByVal NameOrIP As String, ByRef ip As String) As RESOLVE_ERRORS
    'Returns RES_SUCCESS (0) on good result, else error number.
    Dim IPAddr As Long
    Dim wsadStartup As WSAData
    Dim pHeResolve As Long
    Dim heResolve As hostent
    Dim pAddrList As Long
    Dim pIPString As Long
    Dim IPStringLength As Long
    Dim NewIP As String
    
    NameOrIP = Trim$(NameOrIP)
    IPAddr = inet_addr(NameOrIP)
    If IPAddr = INADDR_NONE Then
        Resolve = WSAStartup(WINSOCK_2_2, wsadStartup) 'Possibly a WSA error.
        If Resolve = 0 Then
            pHeResolve = gethostbyname(NameOrIP)
            If pHeResolve = NULL_VALUE Then
                Resolve = Err.LastDllError 'A WSA error.
            Else
                CopyMemory heResolve, ByVal pHeResolve, Len(heResolve)
                CopyMemory pAddrList, ByVal heResolve.h_addr_list, LenB(pAddrList)
                CopyMemory IPAddr, ByVal pAddrList, Len(IPAddr)
                pIPString = inet_ntoa(IPAddr)
                If pIPString = NULL_VALUE Then
                    Resolve = RES_FORMATTING_ERR
                Else
                    IPStringLength = lstrlen(pIPString)
                    NewIP = Space$(IPStringLength)
                    pIPString = lstrcpyn(NewIP, pIPString, IPStringLength + 1)
                    If pIPString = NULL_VALUE Then
                        Resolve = RES_FORMATTING_ERR
                    Else
                        ip = NewIP
                    End If
                End If
            End If
            If WSACleanup() <> 0 Then Resolve = Err.LastDllError 'A WSA error.
        End If
    Else
        ip = NameOrIP
    End If
End Function