BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "pingtrace"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

'**************************************
'Windows API/Global Declarations for :Pi
' ng and TracRT with Winsock.dll
'**************************************


Private Type Inet_address
Byte4 As String * 1
Byte3 As String * 1
Byte2 As String * 1
Byte1 As String * 1
End Type


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
Tos As Byte
Flags As Byte
OptionsSize As Long
OptionsData As String * 128
End Type


Private 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

Private pIPe As IP_ECHO_REPLY
Private pIPo As IP_OPTION_INFORMATION
Private IPLong As Inet_address

Private Declare Function gethostname Lib "wsock32.dll" (ByVal hostname$, 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
Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function IcmpCreateFile Lib "ICMP.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "ICMP.dll" (ByVal HANDLE As Long) As Boolean
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 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, 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

' 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

' WSock32 Constants
Const WS_VERSION_MAJOR = &H101 \ &H100 And &HFF&
Const WS_VERSION_MINOR = &H101 And &HFF&
Const MIN_SOCKETS_REQD = 0

'GetTickCount Declaration
Private Declare Function GetTickCount Lib "Kernel32" () As Long

'COM Vars
Dim sResponse As String
Dim sHost As String
Dim sIp As String
Dim maxPings As Long
Dim aNames(50) As String
Dim aTimes(50) As Long
Dim maxTimes As Long
Dim allNames As String
Public Sub setTime(ByVal name As String)
If InStr(allNames, name + ",") > 0 Then
For x = 0 To maxTimes
If aNames(x) = name Then
aTimes(x) = GetTickCount()
Exit For
End If
Next
Else
maxTimes = maxTimes + 1
aNames(maxTimes) = name
aTimes(maxTimes) = GetTickCount()
allNames = allNames + name + ","
End If
End Sub
Public Function getTime(ByVal name As String) As Long
If InStr(allNames, name) > 0 Then
For x = 0 To maxTimes
If aNames(x) = name Then
getTime = aTimes(x)
Exit For
End If
Next
Else
getTime = 0
End If
End Function
Public Function getNow() As Long
getNow = GetTickCount()
End Function
Public Function formatTime(ByVal lTime1 As Long) As String
Dim hour As Integer, minute As Integer, second As Integer
Dim raw
'The line below gets the tickcount and t
' hen divides
'it by 1000 so you get the total whole n
' umber of
'seconds
raw = lTime1 \ 1000
'Finds number of whole hours
hour = raw \ 3600
'subtracts the number of whole hours
raw = raw - (hour * 3600)
'finds the number of whole minutes
minute = raw \ 60
'subtract the number of minutes
raw = raw - (minute * 60)
'sets the last part as seconds
second = raw
'below will just put the code onto a lab
' el. I just
'made it so it will put a "0" in front o
' f the number
'if the number of seconds/minutes is bel
' ow 10


If minute < 10 Then


If second < 10 Then
sReturn = hour & ":0" & minute & ":0" & second
Else
sReturn = hour & ":0" & minute & ":" & second
End If
Else


If second < 10 Then
sReturn = hour & ":" & minute & ":0" & second
Else
sReturn = hour & ":" & minute & ":" & second
End If
End If
formatTime = sReturn
End Function

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
sResponse = sResponse + " 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
sResponse = sResponse + " Reply from " + RespondingHost + ": " + RCode + Chr$(13) + Chr$(10)
End If
Else
If TTL - 1 < 10 Then sResponse = sResponse + " # 0" + CStr(TTL - 1) Else sResponse = sResponse + " # " + CStr(TTL - 1)
sResponse = sResponse + " " + RespondingHost + Chr$(13) + Chr$(10)
End If
End Sub


Private Sub vbGetHostByName()
Dim szString As String
Host = Trim$(sHost)
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
sIp = 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)
sHost = 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
maxPings = 1
End If


For NbrOfPkts = 1 To maxPings '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
sResponse = sResponse + "Request Timeout" + Chr$(13) + Chr$(10)
End If
End If
Next NbrOfPkts
End Sub


Private 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 "
sResponse = sMsg
Exit Sub
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."
sResponse = sMsg
Exit Sub
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()
Dim ret As Variant
ret = WSACleanup()
End Sub


Private Sub vbIcmpCloseHandle()
bReturn = IcmpCloseHandle(hIP)
End Sub


Private Sub vbIcmpCreateFile()
hIP = IcmpCreateFile()
End Sub


Public Function Ping(ByVal Host As String, ByVal howMany As Long) As String
maxPings = howMany
sHost = Host
sResponse = ""
vbWSAStartup ' Initialize Winsock

If Len(sHost) = 0 Then
vbGetHostName
End If
vbGetHostByName ' Get the IPAddress for the Host
vbIcmpCreateFile ' Get ICMP Handle
' The following determines the TTL of th
' e ICMPEcho
pIPo.TTL = Trim$(255)
vbIcmpSendEcho ' Send the ICMP Echo Request
vbIcmpCloseHandle ' Close the ICMP Handle
vbWSACleanup ' Close Winsock
Ping = sResponse
End Function


Private Sub ClearResponse_Click()
sResponse = "" 'Clear IP
End Sub


Public Function Trace(ByVal Host As String) As String
sHost = Host
sResponse = ""
vbWSAStartup


If Len(sHost) = 0 Then
vbGetHostName
End If
vbGetHostByName
vbIcmpCreateFile
' The following determines the TTL of th
' e ICMPEcho for TRACE function
TraceRT = True
sResponse = sResponse + "Tracing Route to " + sIp + ":" + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10)


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


DoEvents


If RespondingHost = sIp Then
sResponse = sResponse + 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
Trace = sResponse
End Function