Option Explicit On

Imports System
Imports System.Net
Imports System.Net.Sockets

Public Class clsPing

Public Structure stcError
Dim Number As Integer
Dim Description As String
End Structure

Private Const PING_ERROR_BASE As Long = &H8000

Public Const PING_SUCCESS As Long = 0
Public Const PING_ERROR As Long = (-1)
Public Const PING_ERROR_HOST_NOT_FOUND As Long = PING_ERROR_BASE + 1
Public Const PING_ERROR_SOCKET_DIDNT_SEND As Long = PING_ERROR_BASE + 2
Public Const PING_ERROR_HOST_NOT_RESPONDING As Long = PING_ERROR_BASE + 3
Public Const PING_ERROR_TIME_OUT As Long = PING_ERROR_BASE + 4

Private Const ICMP_ECHO As Integer = 8
Private Const SOCKET_ERROR As Integer = -1

Private udtError As stcError

Private Const intPortICMP As Integer = 7
Private Const intBufferHeaderSize As Integer = 8
Private Const intPackageHeaderSize As Integer = 28

Private byteDataSize As Byte
Private lngTimeOut As Long
Private ipheLocalHost As System.Net.IPHostEntry
Private ipheHost As System.Net.IPHostEntry

Public Property TimeOut() As Long
Get
Return lngTimeOut
End Get
Set(ByVal Value As Long)
lngTimeOut = Value
End Set
End Property

Public Property DataSize() As Byte
Get
Return byteDataSize
End Get
Set(ByVal Value As Byte)
byteDataSize = Value
End Set
End Property

Public ReadOnly Property Identifier() As Byte
Get
Return 0
End Get
End Property

Public ReadOnly Property Sequence() As Byte
Get
Return 0
End Get
End Property

Public ReadOnly Property LocalHost() As System.Net.IPHostEntry
Get
Return ipheLocalHost
End Get
End Property

Public Property Host() As Object
Get
Return ipheHost
End Get
Set(ByVal Value As Object)
If (Value.GetType.ToString.ToLower = "system.string") Then

Try
ipheHost = System.Net.Dns.GetHostByName(Value)
Catch
ipheHost = Nothing
udtError.Number = PING_ERROR_HOST_NOT_FOUND
udtError.Description = "Host " & ipheHost.HostName & " not found."
End Try
ElseIf (Value.GetType.ToString.ToLower = "system.net.iphostentry") Then
ipheHost = (Value)
Else
ipheHost = Nothing
End If
End Set
End Property

ipheHost = Nothing

End Sub

Public Function Ping() As Long

Dim intCount As Integer
Dim aReplyBuffer(255) As Byte

Dim intNBytes As Integer = 0

Dim intEnd As Integer
Dim intStart As Integer

Dim epFrom As System.Net.EndPoint
Dim epServer As System.Net.EndPoint
Dim ipepServer As System.Net.IPEndPoint

ipepServer = New System.Net.IPEndPoint(ipheHost.AddressList(0), 0)
epServer = CType(ipepServer, System.Net.EndPoint)

epFrom = New System.Net.IPEndPoint(ipheLocalHost.AddressList(0), 0)

DataSize = Convert.ToByte(DataSize + intBufferHeaderSize)

If (DataSize Mod 2 = 1) Then
DataSize += Convert.ToByte(1)
End If
Dim aRequestBuffer(DataSize - 1) As Byte

aRequestBuffer(0) = Convert.ToByte(8) ' ECHO Request

BitConverter.GetBytes(Identifier).CopyTo(aRequestBuffer, 4)

BitConverter.GetBytes(Sequence).CopyTo(aRequestBuffer, 6)

Dim i As Integer
For i = 8 To DataSize - 1
aRequestBuffer(i) = Convert.ToByte(i Mod 8)
Next i

Call CreateChecksum(aRequestBuffer, DataSize, aRequestBuffer(2), aRequestBuffer(3))

Try
Dim sckSocket As New System.Net.Sockets.Socket( _
Net.Sockets.AddressFamily.InterNetwork, _
Net.Sockets.SocketType.Raw, _
Net.Sockets.ProtocolType.Icmp)
sckSocket.Blocking = False

sckSocket.SendTo(aRequestBuffer, 0, DataSize, SocketFlags.None, ipepServer)

intStart = System.Environment.TickCount

Do
Application.DoEvents()
Try
intNBytes = sckSocket.ReceiveFrom(aReplyBuffer, SocketFlags.None, epServer)
Catch objErr As Exception
End Try
Loop Until (intNBytes > 0) Or ((System.Environment.TickCount - intStart) > TimeOut)

If ((System.Environment.TickCount - intStart) > TimeOut) Then
udtError.Number = PING_ERROR_TIME_OUT
udtError.Description = "Time Out"
Return (PING_ERROR)
End If

intEnd = System.Environment.TickCount

If (intNBytes > 0) Then
udtError.Number = (aReplyBuffer(19) * &H100) + aReplyBuffer(20)
Select Case aReplyBuffer(20)
Case 0 : udtError.Description = "Success"
Case 1 : udtError.Description = "Buffer too Small"
Case 2 : udtError.Description = "Destination Unreahable"
Case 3 : udtError.Description = "Dest Host Not Reachable"
Case 4 : udtError.Description = "Dest Protocol Not Reachable"
Case 5 : udtError.Description = "Dest Port Not Reachable"
Case 6 : udtError.Description = "No Resources Available"
Case 7 : udtError.Description = "Bad Option"
Case 8 : udtError.Description = "Hardware Error"
Case 9 : udtError.Description = "Packet too Big"
Case 10 : udtError.Description = "Reqested Timed Out"
Case 11 : udtError.Description = "Bad Request"
Case 12 : udtError.Description = "Bad Route"
Case 13 : udtError.Description = "TTL Exprd In Transit"
Case 14 : udtError.Description = "TTL Exprd Reassemb"
Case 15 : udtError.Description = "Parameter Problem"
Case 16 : udtError.Description = "Source Quench"
Case 17 : udtError.Description = "Option too Big"
Case 18 : udtError.Description = "Bad Destination"
Case 19 : udtError.Description = "Address Deleted"
Case 20 : udtError.Description = "Spec MTU Change"
Case 21 : udtError.Description = "MTU Change"
Case 22 : udtError.Description = "Unload"
Case Else : udtError.Description = "General Failure"
End Select
End If

Return (intEnd - intStart)
Catch oExcept As Exception
'
End Try

End Function

Public Function GetLastError() As stcError
Return udtError
End Function

Private Sub CreateChecksum(ByRef data() As Byte, ByVal Size As Integer, ByRef HiByte As Byte, ByRef LoByte As Byte)
Dim i As Integer
Dim chk As Integer = 0

For i = 0 To Size - 1 Step 2
chk += Convert.ToInt32(data(i) * &H100 + data(i + 1))
Next

chk = Convert.ToInt32((chk And &HFFFF&) + Fix(chk / &H10000&))
chk += Convert.ToInt32(Fix(chk / &H10000&))
chk = Not (chk)

HiByte = Convert.ToByte((chk And &HFF00) / &H100)
LoByte = Convert.ToByte(chk And &HFF)
End Sub

End Class

Private Sub BtnPING_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles BtnPING.Click

Dim objPingHost As New clsPing
Dim lngPingReply As Long

If (Trim(Me.TxtHost.Text) = "") Then
Call MsgBox("Please, type a host name or IP.", MsgBoxStyle.Exclamation, Application.ProductName)
Exit Sub
End If

objPingHost.TimeOut = 5000 ' --> 5000 msec Time Out
objPingHost.DataSize = 32 ' --> 32 bytes Package Size
objPingHost.Host = Trim(Me.TxtHost.Text) ' --> Host to Ping

Me.TxtLog.Text = "Trying to ping " & Trim(Me.TxtHost.Text) & " ..."

lngPingReply = objPingHost.Ping()

If (lngPingReply = objPingHost.PING_ERROR) Then
Me.TxtLog.Text &= vbCrLf & "Error : " & objPingHost.GetLastError.Description
Else
Me.TxtLog.Text &= vbCrLf & "Ping Reply " & lngPingReply & " msec."
End If

End Sub