Ping and TracRT with Winsock.dll

Category:

Network/Internet

Type:

Snippets

Difficulty:

Advanced

Author: Waty

Version Compatibility:

More information:

Ping and TracRT with Winsock.dll

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
' #VBIDEUtils#********************************************** ' * Programmer Name : Waty Thierry ' * Web Site : www.geocities.com/ResearchTriangle/6311/ ' * E-Mail : waty.thierry@usa.net ' * Date : 28/07/99 ' * Time : 11:06 ' *********************************************************** ' * Comments : Ping and TracRT with Winsock.dll ' * ' * ' '************************************************************ Type Inet_address Byte4 As String * 1 Byte3 As String * 1 Byte2 As String * 1 Byte1 As String * 1 End Type 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 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 Type IP_OPTION_INFORMATION TTL As Byte Tos As Byte Flags As Byte OptionsSize As Long OptionsData As String * 128 End Type Type IP_ECHO_REPLY Address(0 To 3) As Byte Status As Long RoundTripTime As Long DataSize As Integer Reserved As Integer data As Long Options As IP_OPTION_INFORMATION End Type Public pIPe As IP_ECHO_REPLY Public pIPo As IP_OPTION_INFORMATION Public IPLong As Inet_address Public Declare Function gethostname Lib "wsock32.dll" (ByVal _ hostname$, HostLen&) As Long Public Declare Function gethostbyname& Lib "wsock32.dll" (ByVal _ hostname$) Public Declare Function WSAGetLastError Lib "wsock32.dll" () As _ Long Public Declare Function WSAStartup Lib "wsock32.dll" (ByVal _ wVersionRequired&, lpWSAData As WSAdata) As Long Public Declare Function WSACleanup Lib "wsock32.dll" () As Long Public Declare Sub CopyMemory Lib "kernel32" Alias _ "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal _ cbCopy As Long) Public Declare Function IcmpCreateFile Lib "ICMP.dll" () As Long Public Declare Function IcmpCloseHandle Lib "ICMP.dll" _ (ByVal HANDLE As Long) As Boolean Public 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 Constants Const WS_VERSION_MAJOR = &H100 And &HFF& Const WS_VERSION_MINOR = &H101 And &HFF& Const MIN_SOCKETS_REQD = 0

Code:

'create:
'textbox name = Host
'textbox name = Message
'label name = IP
'Button name = TraceRT
'Button name = Ping

' WSock32 Variables
Dim iReturn As Long, sLowByte As String, sHighByte As String
Dim sMsg As String, HostLen As Long, Host As String
Dim Hostent As Hostent, PointerToPointer As Long
Dim ListAddress As Long
Dim WSAdata As WSAdata, DotA As Long, DotAddr As String
Dim ListAddr As Long
Dim MaxUDP As Long, MaxSockets As Long, i As Integer
Dim Description As String, Status As String

' Ping Variables
Dim bReturn As Boolean, hIP As Long
Dim szBuffer As String
Dim Addr As Long
Dim RCode As String
Dim RespondingHost As String

' TRACERT Variables
Dim TraceRT As Boolean
Dim TTL As Integer

Private Sub GetRCode()

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

DoEvents

If TraceRT = False Then

If pIPe.Status = 0 Then
         Response.Text = Response.Text + " Reply from " + RespondingHost + ": Bytes = " + Trim$(CStr(pIPe.DataSize)) + " RTT = " + Trim$(CStr(pIPe.RoundTripTime)) + "ms TTL = " + Trim$(CStr(pIPe.Options.TTL)) + Chr$(13) + Chr$(10)
      Else
         Response.Text = Response.Text + " Reply from " + RespondingHost + ": " + RCode + Chr$(13) + Chr$(10)
      End If

Else
      If TTL - 1 < 10 Then Response.Text = Response.Text + " # 0" + CStr(TTL - 1) Else Response.Text = Response.Text + " # " + CStr(TTL - 1)
      Response.Text = Response.Text + " " + RespondingHost + Chr$(13) + Chr$(10)
   End If

End Sub

Private Sub vbGetHostByName()

Dim szString As String
   Host = Trim$(Host.Text)
   szString = String(64, &H0)
   Host = Host + Right$(szString, 64 - Len(Host))

If gethostbyname(Host) = SOCKET_ERROR Then
      sMsg = "Winsock Error" & Str$(WSAGetLastError())
      MsgBox sMsg ,0 ,""
   Else
      PointerToPointer = gethostbyname(Host)' Get the pointer to the address of the winsock hostent structure
      CopyMemory Hostent.h_name, ByVal _
         PointerToPointer, Len(Hostent)' Copy Winsock structure to the VisualBasic structure
      ListAddress = Hostent.h_addr_list ' Get the ListAddress of the Address List
      CopyMemory ListAddr, ByVal ListAddress, 4 ' Copy Winsock structure to the VisualBasic structure
      CopyMemory IPLong, ByVal ListAddr, 4' Get the first list entry from the Address List
      CopyMemory Addr, ByVal ListAddr, 4
      IP.Caption = Trim$(CStr(Asc(IPLong.Byte4)) + "." + CStr(Asc(IPLong.Byte3)) _
         + "." + CStr(Asc(IPLong.Byte2)) + "." + CStr(Asc(IPLong.Byte1)))
   End If

End Sub

Private Sub vbGetHostName()

Host = String(64, &H0)

If gethostname(Host, HostLen) = SOCKET_ERROR Then
      sMsg = "WSock32 Error" & Str$(WSAGetLastError())
      MsgBox sMsg, 0, ""
   Else
      Host = left$(Trim$(Host), Len(Trim$(Host)) - 1)
      Host.Text = Host
   End If

End Sub

Private Sub vbIcmpSendEcho()

Dim NbrOfPkts As Integer
   szBuffer = "abcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklm"
   szBuffer = left$(szBuffer, Val(32))

If IsNumeric(1) Then
   End If

If TraceRT = True Then
   End If

For NbrOfPkts = 1 To Trim$(1)

DoEvents
      bReturn = IcmpSendEcho(hIP, Addr, szBuffer, Len(szBuffer), pIPo, pIPe, Len(pIPe) + 8, 2700)

If bReturn Then
         RespondingHost = CStr(pIPe.Address(0)) + "." + CStr(pIPe.Address(1)) + "." + CStr(pIPe.Address(2)) + "." + CStr(pIPe.Address(3))
         GetRCode
      Else

If TraceRT Then
            TTL = TTL - 1
         Else
            Response.Text = Response.Text + "Request Timeout" + Chr$(13) + Chr$(10)
         End If

End If

Next NbrOfPkts

End Sub

Sub vbWSAStartup()

iReturn = WSAStartup(&H101, WSAdata)

If iReturn <> 0 Then ' If WSock32 error, then tell me about it
      MsgBox "WSock32.dll is not responding!",0 ,""
   End If

If LoByte(WSAdata.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAdata.wVersion) = WS_VERSION_MAJOR And HiByte(WSAdata.wVersion) < WS_VERSION_MINOR) Then
      sHighByte = Trim$(Str$(HiByte(WSAdata.wVersion)))
      sLowByte = Trim$(Str$(LoByte(WSAdata.wVersion)))
      sMsg = "WinSock Version " & sLowByte & "." & sHighByte
      sMsg = sMsg & " is not supported "
      MsgBox sMsg
      End
   End If

If WSAdata.iMaxSockets < MIN_SOCKETS_REQD Then
      sMsg = "This application requires a minimum of "
      sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
      	MsgBox sMsg
      End
   End If

MaxSockets = WSAdata.iMaxSockets

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

MaxUDP = WSAdata.iMaxUdpDg

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

Description = ""

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

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 vbWSACleanup()

Return = WSACleanup()
End Sub

Private Sub vbIcmpCloseHandle()

bReturn = IcmpCloseHandle(hIP)
End Sub

Private Sub vbIcmpCreateFile()

hIP = IcmpCreateFile()
End Sub

Private Sub Ping_Click()

Response.Enabled = True
   Response.Text = ""
   vbWSAStartup''' Initialize Winsock

If Len(Host.Text) = 0 Then
      vbGetHostName
   End If

vbGetHostByName ' Get the IPAddress For the Host
   vbIcmpCreateFile ' Get ICMP Handle
   ' The following determines the TTL of the ICMPEcho
   pIPo.TTL = Trim$(255)
   vbIcmpSendEcho''' Send the ICMP Echo Request
   vbIcmpCloseHandle ' Close the ICMP Handle
   vbWSACleanup''' Close Winsock
End Sub

Private Sub ClearResponse_Click()

Response.Text = "" 'Clear IP
End Sub

Private Sub TraceRT_Click()

Response.Enabled = True
   Response.Text = ""
   vbWSAStartup

If Len(Host.Text) = 0 Then
      vbGetHostName
   End If

vbGetHostByName
   vbIcmpCreateFile
   ' The following determines the TTL of the ICMPEcho for TRACE func
   '     tion
   TraceRT = True
   Response.Text = Response.Text + "Tracing Route to " + IP.Caption + ":" + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10)

For TTL = 2 To 255
      pIPo.TTL = TTL
      vbIcmpSendEcho

DoEvents

If RespondingHost = IP.Caption Then
         Response.Text = Response.Text + Chr$(13) + Chr$(10) + "Route Trace has Completed" + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10)
         Exit For ' Stop TraceRT
      End If

Next TTL

TraceRT = False
   vbIcmpCloseHandle
   vbWSACleanup
End Sub