VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cls_ICMP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'
' WSock32 UDTs
'
Private Type Inet_address
    Byte4 As String * 1
    Byte3 As String * 1
    Byte2 As String * 1
    Byte1 As String * 1
End Type
'
Private m_IPLong As Inet_address
'
Private Type WSAdata
    wVersion As Integer
    wHighVersion As Integer
    szDescription(0 To 255) As Byte
    szSystemStatus(0 To 128) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type
'
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 IP_OPTION_INFORMATION
    TTL As Byte                   ' Time to Live (used for traceroute)
    Tos As Byte                   ' Type of Service (usually 0)
    Flags As Byte                 ' IP header Flags (usually 0)
    OptionsSize As Long           ' Size of Options data (usually 0, max 40)
    OptionsData As String * 128   ' Options data buffer
End Type
'
Private m_pIPo As IP_OPTION_INFORMATION
'
Private Type IP_ECHO_REPLY
    Address(0 To 3) As Byte           ' Replying Address
    Status As Long                    ' Reply Status
    RoundTripTime As Long             ' Round Trip Time in milliseconds
    DataSize As Integer               ' reply data size
    Reserved As Integer               ' for system use
    data As Long                      ' pointer to echo data
    Options As IP_OPTION_INFORMATION  ' Reply Options
End Type
'
Private m_pIPe As IP_ECHO_REPLY
'
' WSock32 Subroutines and Functions
'
Private Declare Function gethostname Lib "wsock32.dll" (ByVal hostname$, m_HostLen&) As Long
Private Declare Function gethostbyname& Lib "wsock32.dll" (ByVal hostname$)
Private Declare Function WSAGetLastError Lib "wsock32.dll" () As Long
Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired&, lpWSAData As WSAdata) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
'
' Kernel32 Subroutines and Functions
'
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'
' ICMP Subroutines and Functions
'
' IcmpCreateFile will return a file handle
'
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
'
' Pass the handle value from IcmpCreateFile to the IcmpCloseHandle.  It will return
' a boolean value indicating whether or not it closed successfully.
'
Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal HANDLE As Long) As Boolean
'
' IcmpHandle returned from IcmpCreateFile
' DestAddress is a pointer to the first entry in the hostent.h_addr_list
' RequestData is a null-terminated 64-byte string filled with ASCII 170 characters
' RequestSize is 64-bytes
' RequestOptions is a NULL at this time
' ReplyBuffer
' ReplySize
' Timeout is the timeout in milliseconds
'
Private Declare Function IcmpSendEcho Lib "ICMP" (ByVal IcmpHandle As Long, ByVal DestAddress As Long, _
    ByVal RequestData As String, ByVal RequestSize As Integer, RequestOptns As IP_OPTION_INFORMATION, _
     ReplyBuffer As IP_ECHO_REPLY, ByVal ReplySize As Long, ByVal TimeOut As Long) As Boolean
'
' WSock32 Variables
'
Dim m_iReturn As Long, m_sLowByte As String, m_sHighByte As String
Dim m_sMsg As String, m_HostLen As Long, m_Host As String
Dim m_Hostent As Hostent, PointerToPointer As Long, ListAddress As Long
Dim WSAdata As WSAdata, DotA As Long, DotAddr As String, ListAddr As Long
Dim MaxUDP As Long, MaxSockets As Long, i As Integer
Dim Description As String, Status As String
'
' ICMP Variables
'
Dim bReturn As Boolean, hIP As Long
Dim szBuffer As String
Dim Addr As Long
Dim RCode As String
Dim m_strRespondingHost As String
'
Private m_blnValidHost As Boolean
'
' TraceRT Variables
'
Dim m_blnTraceRT As Boolean
Dim m_TTL As Integer
'
' WSock32 Constants
'
Private Const WS_VERSION_MAJOR = &H101 \ &H100 And &HFF&
Private Const WS_VERSION_MINOR = &H101 And &HFF&
Private Const MIN_SOCKETS_REQD = 0
'
Private Const INADDR_NONE = &HFFFF
Private Const SOCKET_ERROR = -1
Private Const WSABASEERR = 10000
Private Const WSAEFAULT = (WSABASEERR + 14)
Private Const WSAEINVAL = (WSABASEERR + 22)
Private Const WSAEINPROGRESS = (WSABASEERR + 50)
Private Const WSAENETDOWN = (WSABASEERR + 50)
Private Const WSASYSNOTREADY = (WSABASEERR + 91)
Private Const WSAVERNOTSUPPORTED = (WSABASEERR + 92)
Private Const WSANOTINITIALISED = (WSABASEERR + 93)
Private Const WSAHOST_NOT_FOUND = 11001
Private Const WSADESCRIPTION_LEN = 257
Private Const WSASYS_STATUS_LEN = 129
Private Const WSATRY_AGAIN = 11002
Private Const WSANO_RECOVERY = 11003
Private Const WSANO_DATA = 11004
'

Private Sub Startup(strIP_Address As String)
    vbWSAStartup
    vbGetHostByName strIP_Address
    CreateFile
    TTL = "255"
End Sub

Private Sub ShutDown()
    CloseHandle
    vbWSACleanup
End Sub

Public Function IsAddressValid(strIP_Address As String) As Boolean
On Error GoTo Err
    '
    Startup strIP_Address
    '
    If Not m_blnValidHost Then
        IsAddressValid = False
    Else
        IsAddressValid = True
    End If
    '
    ShutDown
    '
    Exit Function
    '
Err:
    IsAddressValid = False
End Function

Public Function IsAddressAlive(strIP_Address As String, strTimeout As String) As Boolean
On Error GoTo Err
    '
    Startup strIP_Address
    '
    If Not m_blnValidHost Then
        IsAddressAlive = False
    Else
        '
        szBuffer = "abcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklm"
        szBuffer = Left$(szBuffer, Val("32"))
        bReturn = IcmpSendEcho(hIP, Addr, szBuffer, Len(szBuffer), m_pIPo, m_pIPe, Len(m_pIPe) + 8, CLng(strTimeout))
        '
        If bReturn Then
            IsAddressAlive = True
        Else
            IsAddressAlive = False
        End If
        '
    End If
    '
    ShutDown
    '
    Exit Function
    '
Err:
    IsAddressAlive = False
End Function

Public Function TraceRoute(strIP_Address As String, strTimeout As String) As String
    '
    Dim i As Integer
    Dim strRespondingHost As String
    '
    Startup strIP_Address
    '
    TraceRT = True
    '
    TraceRoute = TraceRoute & "Tracing Route to " & strIP_Address & ":" & Chr$(13) & Chr$(10) & Chr$(13) & Chr$(10)
    '
    szBuffer = "abcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklm"
    szBuffer = Left$(szBuffer, Val("32"))
    bReturn = IcmpSendEcho(hIP, Addr, szBuffer, Len(szBuffer), m_pIPo, m_pIPe, Len(m_pIPe) & 8, CLng(strTimeout))
    '
    strRespondingHost = RespondingHost
    '
    For i = 2 To 255
        '
        TTL = i
        '
        bReturn = IcmpSendEcho(hIP, Addr, szBuffer, Len(szBuffer), m_pIPo, m_pIPe, Len(m_pIPe) & 8, CLng(strTimeout))
        '
        If bReturn Then
            TraceRoute = TraceRoute & CStr(m_pIPe.Address(0)) & "." & CStr(m_pIPe.Address(1)) & "." & CStr(m_pIPe.Address(2)) & "." & CStr(m_pIPe.Address(3)) & vbCrLf
        End If
        '
        If RespondingHost = strRespondingHost Then
            TraceRoute = TraceRoute & Chr$(13) & Chr$(10) & "Route Trace has Completed" & Chr$(13) & Chr$(10) & Chr$(13) & Chr$(10)
            Exit For
        End If
        '
    Next
    '
    TraceRT = False
    '
    ShutDown
    '
End Function

Public Function AverageResponseTime(strIP_Address As String, strCharsPerPacket As String, strNumberOfPackets As String, strTimeout As String) As String
    '
    Dim NbrOfPkts As Integer
    Dim lngResponseTotal As Long
    Dim intResponses As Integer
    Dim lngResponseDataTotalSize As Long
    '
    Startup strIP_Address
    '
    szBuffer = "abcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklm"
    '
    If IsNumeric(strCharsPerPacket) Then
        If Val(strCharsPerPacket) < 32 Then strCharsPerPacket = "32"
        If Val(strCharsPerPacket) > 128 Then strCharsPerPacket = "128"
    Else
        strCharsPerPacket = "32"
    End If
    '
    szBuffer = Left$(szBuffer, Val(strCharsPerPacket))
    '
    If IsNumeric(strNumberOfPackets) Then
        If Val(strNumberOfPackets) < 1 Then strNumberOfPackets = "1"
    Else
        strNumberOfPackets = "1"
    End If
    '
    If m_blnTraceRT = True Then strNumberOfPackets = "1"
    '
    For NbrOfPkts = 1 To Trim$(strNumberOfPackets)
        '
        intResponses = intResponses + 1
        '
        DoEvents
        bReturn = IcmpSendEcho(hIP, Addr, szBuffer, Len(szBuffer), m_pIPo, m_pIPe, Len(m_pIPe) + 8, CLng(strTimeout))
        '
        If bReturn Then
            lngResponseTotal = lngResponseTotal + m_pIPe.RoundTripTime
        End If
        '
    Next
    '
    AverageResponseTime = CLng(lngResponseTotal / intResponses)
    '
    ShutDown
    '
End Function

Public Function SendEcho(strIP_Address As String, strCharsPerPacket As String, strNumberOfPackets As String, strTimeout As String) As String
    '
    Dim NbrOfPkts As Integer
    '
    Startup strIP_Address
    '
    szBuffer = "abcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklm"
    '
    If IsNumeric(strCharsPerPacket) Then
        If Val(strCharsPerPacket) < 32 Then strCharsPerPacket = "32"
        If Val(strCharsPerPacket) > 128 Then strCharsPerPacket = "128"
    Else
        strCharsPerPacket = "32"
    End If
    '
    szBuffer = Left$(szBuffer, Val(strCharsPerPacket))
    '
    If IsNumeric(strNumberOfPackets) Then
        If Val(strNumberOfPackets) < 1 Then strNumberOfPackets = "1"
    Else
        strNumberOfPackets = "1"
    End If
    '
    If m_blnTraceRT = True Then strNumberOfPackets = "1"
    '
    For NbrOfPkts = 1 To Trim$(strNumberOfPackets)
        '
        DoEvents
        bReturn = IcmpSendEcho(hIP, Addr, szBuffer, Len(szBuffer), m_pIPo, m_pIPe, Len(m_pIPe) + 8, CLng(strTimeout))
        '
        If bReturn Then
            m_strRespondingHost = CStr(m_pIPe.Address(0)) + "." + CStr(m_pIPe.Address(1)) + "." + CStr(m_pIPe.Address(2)) + "." + CStr(m_pIPe.Address(3))
            SendEcho = SendEcho + GetRCode
        Else
            ' during a m_blnTraceRT, try again.
            '
            If m_blnTraceRT Then
                m_TTL = m_TTL - 1
            Else    ' Don't worry about trying again on a PING, just timeout
                SendEcho = SendEcho + "ICMP Request Timeout" + Chr$(13) + Chr$(10)
            End If
            '
        End If
        '
    Next
    '
    ShutDown
    '
End Function

Private Function GetRCode() As String

    If m_pIPe.Status = 0 Then RCode = "Success"
    If m_pIPe.Status = 11001 Then RCode = "Buffer too Small"
    If m_pIPe.Status = 11002 Then RCode = "Dest Network Not Reachable"
    If m_pIPe.Status = 11003 Then RCode = "Dest m_Host Not Reachable"
    If m_pIPe.Status = 11004 Then RCode = "Dest Protocol Not Reachable"
    If m_pIPe.Status = 11005 Then RCode = "Dest Port Not Reachable"
    If m_pIPe.Status = 11006 Then RCode = "No Resources Available"
    If m_pIPe.Status = 11007 Then RCode = "Bad Option"
    If m_pIPe.Status = 11008 Then RCode = "Hardware Error"
    If m_pIPe.Status = 11009 Then RCode = "Packet too Big"
    If m_pIPe.Status = 11010 Then RCode = "Rqst Timed Out"
    If m_pIPe.Status = 11011 Then RCode = "Bad Request"
    If m_pIPe.Status = 11012 Then RCode = "Bad Route"
    If m_pIPe.Status = 11013 Then RCode = "TTL Exprd in Transit"
    If m_pIPe.Status = 11014 Then RCode = "TTL Exprd Reassemb"
    If m_pIPe.Status = 11015 Then RCode = "Parameter Problem"
    If m_pIPe.Status = 11016 Then RCode = "Source Quench"
    If m_pIPe.Status = 11017 Then RCode = "Option too Big"
    If m_pIPe.Status = 11018 Then RCode = " Bad Destination"
    If m_pIPe.Status = 11019 Then RCode = "Address Deleted"
    If m_pIPe.Status = 11020 Then RCode = "Spec MTU Change"
    If m_pIPe.Status = 11021 Then RCode = "MTU Change"
    If m_pIPe.Status = 11022 Then RCode = "Unload"
    If m_pIPe.Status = 11050 Then RCode = "General Failure"
    RCode = RCode + " (" + CStr(m_pIPe.Status) + ")"

    DoEvents
    If m_blnTraceRT = False Then
    
        If m_pIPe.Status = 0 Then
            GetRCode = GetRCode + "  Reply from " + m_strRespondingHost + ": Bytes = " + Trim$(CStr(m_pIPe.DataSize)) + " RTT = " + Trim$(CStr(m_pIPe.RoundTripTime)) + "ms TTL = " + Trim$(CStr(m_pIPe.Options.TTL)) + Chr$(13) + Chr$(10)
        Else
            GetRCode = GetRCode + "  Reply from " + m_strRespondingHost + ": " + RCode + Chr$(13) + Chr$(10)
        End If

    Else
        If m_TTL - 1 < 10 Then GetRCode = GetRCode + "  Hop # 0" + CStr(m_TTL - 1) Else GetRCode = GetRCode + "  Hop # " + CStr(m_TTL - 1)
        GetRCode = GetRCode + "  " + m_strRespondingHost + Chr$(13) + Chr$(10)
    End If

End Function

Private Function vbGetHostByName(strHostName As String) As String
On Error GoTo Err

    Dim szString As String
    Dim lngReturn As Long

    m_Host = Left(Trim$(strHostName), 63)              ' Set Variable m_Host to Value in txtHostName.text

    szString = String(64, &H0)
    m_Host = m_Host + Right$(szString, 64 - Len(m_Host))

    lngReturn = gethostbyname(m_Host)
    
    If lngReturn = SOCKET_ERROR Or lngReturn = 0 Then
        m_blnValidHost = False
        m_sMsg = "Winsock Error" & Str$(WSAGetLastError())
        Err.Raise -1, "cls_ICMP", "Invalid Host Name"
    Else
        m_blnValidHost = True
        PointerToPointer = gethostbyname(m_Host)              ' Get the pointer to the address of the winsock hostent structure
        CopyMemory m_Hostent.h_name, ByVal _
        PointerToPointer, Len(m_Hostent)                       ' Copy Winsock structure to the VisualBasic structure

        ListAddress = m_Hostent.h_addr_list                   ' Get the ListAddress of the Address List
        CopyMemory ListAddr, ByVal ListAddress, 4           ' Copy Winsock structure to the VisualBasic structure
        CopyMemory m_IPLong, ByVal ListAddr, 4                ' Get the first list entry from the Address List
        CopyMemory Addr, ByVal ListAddr, 4

        vbGetHostByName = Trim$(CStr(Asc(m_IPLong.Byte4)) + "." + CStr(Asc(m_IPLong.Byte3)) _
            + "." + CStr(Asc(m_IPLong.Byte2)) + "." + CStr(Asc(m_IPLong.Byte1)))
    End If
    '
    Exit Function
    '
Err:
    If Err.Number = 5 Then
        Err.Raise -1, "cls_ICMP", "Invalid Host Name"
    Else
        Err.Raise Err.Number, Err.Source, Err.Description
    End If
End Function

Private Sub vbWSAStartup()
    
    ' Subroutine to Initialize WSock32

    m_iReturn = WSAStartup(&H101, WSAdata)

    If m_iReturn <> 0 Then    ' If WSock32 error, then tell me about it
        MsgBox "WSock32.dll is not responding!", vbOKOnly, "VB4032-ICMPEcho"
    End If

    If LoByte(WSAdata.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAdata.wVersion) = WS_VERSION_MAJOR And HiByte(WSAdata.wVersion) < WS_VERSION_MINOR) Then
        m_sHighByte = Trim$(Str$(HiByte(WSAdata.wVersion)))
        m_sLowByte = Trim$(Str$(LoByte(WSAdata.wVersion)))
        
        m_sMsg = "WinSock Version " & m_sLowByte & "." & m_sHighByte
        m_sMsg = m_sMsg & " is not supported "
        MsgBox m_sMsg, vbOKOnly, "VB4032-ICMPEcho"
        End
    End If

    If WSAdata.iMaxSockets < MIN_SOCKETS_REQD Then
        m_sMsg = "This application requires a minimum of "
        m_sMsg = m_sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
        MsgBox m_sMsg, vbOKOnly, "VB4032-ICMPEcho"
        End
    End If
    
    MaxSockets = WSAdata.iMaxSockets

    '  WSAdata.iMaxSockets is an unsigned short, so we have to convert it to a signed long

    If MaxSockets < 0 Then
        MaxSockets = 65536 + MaxSockets
    End If

    MaxUDP = WSAdata.iMaxUdpDg
    If MaxUDP < 0 Then
        MaxUDP = 65536 + MaxUDP
    End If

    '  Process the Winsock Description information
 
    Description = ""

    For i = 0 To WSADESCRIPTION_LEN
        If WSAdata.szDescription(i) = 0 Then Exit For
        Description = Description + Chr$(WSAdata.szDescription(i))
    Next i

    '  Process the Winsock Status information

    Status = ""

    For i = 0 To WSASYS_STATUS_LEN
        If WSAdata.szSystemStatus(i) = 0 Then Exit For
        Status = Status + Chr$(WSAdata.szSystemStatus(i))
    Next i

End Sub

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

Private Sub CreateFile()

    hIP = IcmpCreateFile()

    If hIP = 0 Then
        MsgBox "Unable to Create File Handle", vbOKOnly, "VBPing32"
    End If

End Sub

Private Sub CloseHandle()
  
    bReturn = IcmpCloseHandle(hIP)
    
    If bReturn = False Then
        MsgBox "ICMP Closed with Error", vbOKOnly, "VB4032-ICMPEcho"
    End If

End Sub

Private Sub vbWSACleanup()

    m_iReturn = WSACleanup()

    If m_iReturn <> 0 Then       ' If WSock32 error, then tell me about it.
        m_sMsg = "WSock32 Error - " & Trim$(Str$(m_iReturn)) & " occurred in Cleanup"
        MsgBox m_sMsg, vbOKOnly, "VB4032-ICMPEcho"
        End
    End If

End Sub

Private Property Get TTL() As String
    TTL = m_pIPo.TTL
End Property

Private Property Let TTL(ByVal vNewValue As String)
    m_pIPo.TTL = vNewValue
End Property

Private Property Get TraceRT() As Boolean
    TraceRT = m_blnTraceRT
End Property

Private Property Let TraceRT(ByVal vNewValue As Boolean)
    m_blnTraceRT = vNewValue
End Property

Private Property Get RespondingHost() As String
    RespondingHost = CStr(m_pIPe.Address(0)) & "." & CStr(m_pIPe.Address(1)) & "." & CStr(m_pIPe.Address(2)) & "." & CStr(m_pIPe.Address(3))
End Property