CodeItBetter Programming Another VB Programming Blog

Option Explicit
 
'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 MAX_WSADescription = 256
Const MAX_WSASYSStatus = 128
 
Type ICMP_OPTIONS
    Ttl As Byte
    Tos As Byte
    Flags As Byte
    OptionsSize As Byte
    OptionsData As Long
End Type
 
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
 
Type HOSTENT
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLen As Integer
    hAddrList As Long
End Type
 
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
 
Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long
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
Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long
Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
 
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
 
Function HiByte(ByVal wParam As Integer)
    HiByte = wParam \ &H100 And &HFF&
End Function
 
Function LoByte(ByVal wParam As Integer)
    LoByte = wParam And &HFF&
End Function
 
Function Ping(szAddress As String, ECHO As ICMP_ECHO_REPLY) As Long
    Dim hPort As Long, dwAddress As Long
    Dim sDataToSend As String
    sDataToSend = "Send this"
    dwAddress = AddressStringToLong(szAddress)
    Call SocketsInitialize
    hPort = IcmpCreateFile()
    If IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), 0, ECHO, Len(ECHO), PING_TIMEOUT) Then
        'the ping succeeded,
        '.Status will be 0
        '.RoundTripTime is the time in ms for the ping to complete,
        '.Data is the data returned (NULL terminated)
        '.Address is the Ip address that actually replied
        '.DataSize is the size of the string in .Data
        Ping = ECHO.RoundTripTime
    Else
        Ping = ECHO.status * -1
    End If
    Call IcmpCloseHandle(hPort)
    Call SocketsCleanup
End Function
 
Function AddressStringToLong(ByVal tmp As String) As Long
    Dim I As Integer
    Dim parts(1 To 4) As String
    I = 0
    'we have to extract each part of the 123.456.789.123 string, delimited by a period
    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
    'build the long value out of the hex of the extracted strings
    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
 
Function SocketsCleanup() As Boolean
    Dim X As Long
    X = WSACleanup()
    If X <> 0 Then
        MsgBox "Windows Sockets error " & Trim$(Str$(X)) & " occurred in Cleanup.", vbExclamation
        SocketsCleanup = False
    Else
        SocketsCleanup = True
    End If
End Function
 
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
        MsgBox "Windows Sockets for 32 bit Windows " & "environments is not successfully responding."
        SocketsInitialize = False
        Exit Function
    End If
    If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
        szHiByte = Trim$(Str$(HiByte(WSAD.wVersion)))
        szLoByte = Trim$(Str$(LoByte(WSAD.wVersion)))
        szBuf = "Windows Sockets Version " & szLoByte & "." & szHiByte
        szBuf = szBuf & " is not supported by Windows " & "Sockets for 32 bit Windows environments."
        MsgBox szBuf, vbExclamation
        SocketsInitialize = False
        Exit Function
    End If
    If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
        szBuf = "This application requires a minimum of " & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
        MsgBox szBuf, vbExclamation
        SocketsInitialize = False
        Exit Function
    End If
    SocketsInitialize = True
End Function
 
Sub Main()
    Dim ECHO As ICMP_ECHO_REPLY
    Call Ping("192.168.1.10", ECHO)
    Debug.Print GetStatusCode(ECHO.status)
End Sub