Public ADDRESS_TO_PING
Public ADDRESS_TO_TRACERT
Public TRACERT_OUTPUT_FILENAME
Public NUMBER_OF_RETRY_FOR_TIMEOUT_HOPS
Public POLLING_INTERVAL_IN_MINUTES As Long
Dim strTXT1
Dim strTXT2
Dim strTXT3
Dim strTXT4
Dim Check1 As Boolean
Dim TimeOutCntr As Integer
Dim FileScrptObj As New Scripting.FileSystemObject
Dim File
Dim FileObj
'Dim SunRiping As New ECSPing.Pinger
Dim Pingreslt As Integer
Dim BoolGateway1 As Boolean
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type
Dim ToggleSwitch As Boolean
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Declare Function CreateProcess Lib "kernel32" _
Alias "CreateProcessA" _
(ByVal lpApplicationName As String, _
ByVal lpCommandLine As String, _
lpProcessAttributes As Any, _
lpThreadAttributes As Any, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
lpEnvironment As Any, _
ByVal lpCurrentDriectory As String, _
lpStartupInfo As STARTUPINFO, _
lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" _
(ByVal dwAccess As Long, _
ByVal fInherit As Integer, _
ByVal hObject As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" _
(ByVal hProcess As Long, _
ByVal uExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Const SYNCHRONIZE = 1048576
Const NORMAL_PRIORITY_CLASS = &H20&
Public Function TraceRT()
TimeOutCntr = 0
Dim ipo As ICMP_OPTIONS
Dim echo As ICMP_ECHO_REPLY
Dim ttl As Integer
Dim ttlAdjust As Integer
Dim hPort As Long
Dim nChrsPerPacket As Long
Dim dwAddress As Long
Dim sAddress As String
Dim sHostIP As String
'set up
strTXT1 = "" 'the target IP
strTXT2 = "1" 'force the no of packets = 1 for a tracert
strTXT4 = "" 'clear the output window
'List1.Clear 'for info/debuging only
'the chars per packet - can be between 32 and 128
If IsNumeric(strTXT3) Then
If Val(strTXT3) < 32 Then strTXT3 = "32"
If Val(strTXT3) > 128 Then strTXT3 = "128"
Else
strTXT3 = "32"
End If
nChrsPerPacket = Val(strTXT3)
If SocketsInitialize() Then
'returns the IP Address for the Host in Combo 1
'ie returns 209.68.48.118 for www.mvps.org
sAddress = GetIPFromHostName(ADDRESS_TO_TRACERT)
'convert the address into an internet address.
'ie returns 1982874833 when passed 209.68.48.118
dwAddress = inet_addr(sAddress)
'open an internet file handle
hPort = IcmpCreateFile()
If hPort <> 0 Then
'update the textboxes
strTXT1 = sAddress
strTXT4 = "Tracing Route to " + ADDRESS_TO_TRACERT + ":" & vbCrLf &
vbCrLf
'The heart of the call. See the VBnet
'page description of the TraceRt TTL
'member and its use in performing a
'Trace Route.
For ttl = 1 To 255
'--------------------------------
'for demo/dedbugging only. The
'list will show each TTL passed
'to the calls. Duplicate TTL's
'mean the request timed out, and
'additional attempts to obtain
'the route were tried.
'List1.AddItem ttl
'--------------------------------
'set the IPO time to live
'value to the current hop
ipo.ttl = ttl
'Call the API.
'
'Two items of consequence happen here.
'First, the return value of the call is
'assigned to an 'adjustment' variable. If
'the call was successful, the adjustment
'is 0, and the Next will increment the TTL
'to obtain the next hop. If the return value
'is 1, 1 is subtacted from the TTL value, so
'when the next increments the TTL counter it
'will be the same value as the last pass. In
'doing this, routers that time out are retried
'to ensure a completed route is determined.
'(The values in the List1 show the actual
' hops/tries that the method made.)
'i.e. if the TTL = 3 and it times out,
' adjust = 1 so ttl - 1 = 2. On
' encountering the Next, TTL is
' reset to 3 and the route is tried again.
'The second thing happening concerns the
'sHostIP member of the call. When the call
'returns, sHostIP will contain the name
'of the traced host IP. If it matches the
'string initially used to create the address
'(above) were at the target, so end.
ttlAdjust = TraceRTSendEcho(hPort, _
dwAddress, _
nChrsPerPacket, _
sHostIP, _
echo, _
ipo)
ttl = ttl - ttlAdjust
'need some processing time
DoEvents
If sHostIP = strTXT1 Then
'we're done
strTXT4 = strTXT4 & vbCrLf + "Trace Route Complete"
Exit For
ElseIf TimeOutCntr > NUMBER_OF_RETRY_FOR_TIMEOUT_HOPS Then
strTXT4 = strTXT4 & vbCrLf + "Trace Route Complete with
Errors Request Times out here"
OutputTXTFile strTXT4, "TRACE ROUTE TO " & ADDRESS_TO_TRACERT
Exit For
End If
Next ttl
'clean up
Call IcmpCloseHandle(hPort)
Else: OutputTXTFile "Unable to Open an Icmp File Handle", "ERRORS IN
TRACEROUTER "
End If 'If hPort
'clean up
Call SocketsCleanup
Else: OutputTXTFile "Unable to initialize the Windows Sockets", "ERRORS
IN TRACE ROUTER "
End If 'if SocketsInitialize()
End Function
Private Sub ShowResults(timeToLive As Byte, _
tripTime As Long, _
sHostIP As String)
Dim sTripTime As String
Dim buff As String
Dim tmp As String
'format a string representing
'the round trip time
Select Case tripTime
Case Is < 10: sTripTime = "<10 ms"
Case Is > 1200: sTripTime = "*"
Case Else: sTripTime = CStr(tripTime) & " ms"
End Select
'cache the textbox
buff = strTXT4
'create a new entry
tmp = "Hop #" & vbTab & _
CStr(timeToLive) & vbTab & _
sTripTime & vbTab & _
sHostIP & vbCrLf
'update textbox
strTXT4 = buff & tmp
End Sub
Private Function TraceRTSendEcho(hPort As Long, _
dwAddress As Long, _
nChrsPerPacket As Long, _
sHostIP As String, _
echo As ICMP_ECHO_REPLY, _
ipo As ICMP_OPTIONS) As Integer
Dim sData As String
Dim sError As String
Dim sHostName As String
Dim ttl As Integer
'create a buffer to send
sData = String$(nChrsPerPacket, "a")
If IcmpSendEcho(hPort, _
dwAddress, _
sData, _
Len(sData), _
ipo, _
echo, _
Len(echo) + 8, _
2400) = 1 Then
'a reply was received, so update the display
sHostIP = GetIPFromAddress(echo.Address)
ShowResults ipo.ttl, echo.RoundTripTime, sHostIP
'return 0 to continue with retrieval
TraceRTSendEcho = 0
Else
'a timeout was received, so set the
'return value to 1. In the TraceRT
'calling routine, the TTL will be
'de-incremented by 1, causing the
'for / next to retry this hop.
TraceRTSendEcho = 1
TimeOutCntr = TimeOutCntr + 1
End If
End Function
VB MODULE Content______________________________
Option Explicit
Private Const WSADescription_Len As Long = 255 '256, 0-based
Private Const WSASYS_Status_Len As Long = 127 '128, 0-based
Private Const WS_VERSION_REQD As Long = &H101
Private Const SOCKET_ERROR As Long = -1
Private Const AF_INET As Long = 2
Private Const IP_SUCCESS As Long = 0
Private Const MIN_SOCKETS_REQD As Long = 1
Public Const EM_SETTABSTOPS As Long = &HCB
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To WSADescription_Len) As Byte
szSystemStatus(0 To WSASYS_Status_Len) As Byte
imaxsockets As Integer
imaxudp As Integer
lpszvenderinfo As Long
End Type
Public Type ICMP_OPTIONS
ttl As Byte 'Time To Live
Tos As Byte 'Timeout
Flags As Byte 'option flags
OptionsSize As Long '
OptionsData As Long '
End Type
Public Type ICMP_ECHO_REPLY
Address As Long 'replying address
Status As Long 'reply status code
RoundTripTime As Long 'round-trip time, in milliseconds
datasize As Integer 'reply data size. Always an Int.
Reserved As Integer 'reserved for future use
DataPointer As Long 'pointer to the data in Data below
Options As ICMP_OPTIONS 'reply options, used in tracert
ReturnedData As String * 256 'the returned data follows the
'reply message. The data string
'must be sufficiently large enough
'to hold the returned data.
End Type
Public Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function WSAStartup Lib "wsock32.dll" _
(ByVal VersionReq As Long, _
WSADataReturn As WSADATA) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
Public Declare Function inet_addr Lib "wsock32.dll" _
(ByVal s As String) As Long
Private Declare Function gethostbyaddr Lib "wsock32.dll" _
(haddr As Long, _
ByVal hnlen As Long, _
ByVal addrtype As Long) As Long
Private Declare Function gethostname Lib "wsock32.dll" _
(ByVal szHost As String, _
ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "wsock32.dll" _
(ByVal szHost As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Dest As Any, _
Source As Any, _
ByVal nbytes As Long)
Private Declare Function inet_ntoa Lib "wsock32.dll" _
(ByVal addr As Long) As Long
Private Declare Function lstrcpyA Lib "kernel32" _
(ByVal RetVal As String, _
ByVal Ptr As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" _
(ByVal Ptr As Any) As Long
Public Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Public Declare Function IcmpCloseHandle Lib "icmp.dll" _
(ByVal IcmpHandle As Long) As Long
Public Declare Function IcmpSendEcho Lib "icmp.dll" _
(ByVal IcmpHandle As Long, _
ByVal DestinationAddress As Long, _
ByVal RequestData As String, _
ByVal RequestSize As Long, _
RequestOptions As ICMP_OPTIONS, _
ReplyBuffer As ICMP_ECHO_REPLY, _
ByVal ReplySize As Long, _
ByVal Timeout As Long) As Long
Public Function GetIPFromHostName(ByVal sHostName As String) As String
'converts a host name to an IP address.
Dim ptrHosent As Long 'address of hostent structure
Dim ptrName As Long 'address of name pointer
Dim ptrAddress As Long 'address of address pointer
Dim ptrIPAddress As Long 'address of string holding final IP address
Dim dwAddress As Long 'the final IP address
ptrHosent = gethostbyname(sHostName & vbNullChar)
If ptrHosent <> 0 Then
'assign pointer addresses and offset
'ptrName is the official name of the host (PC).
'If using the DNS or similar resolution system,
'it is the Fully Qualified Domain Name (FQDN)
'that caused the server to return a reply.
'If using a local hosts file, it is the first
'entry after the IP address.
ptrName = ptrHosent
'Null-terminated list of addresses for the host.
'The Address is offset 12 bytes from the start of
'the HOSENT structure. Addresses are returned
'in network byte order.
ptrAddress = ptrHosent + 12
'get the actual IP address
CopyMemory ptrAddress, ByVal ptrAddress, 4
CopyMemory ptrIPAddress, ByVal ptrAddress, 4
CopyMemory dwAddress, ByVal ptrIPAddress, 4
GetIPFromHostName = GetIPFromAddress(dwAddress)
End If
End Function
Public Sub SocketsCleanup()
'only show error if unable to clean up the sockets
If WSACleanup() <> 0 Then
OutputTXTFile "Windows Sockets error occurred during Cleanup.",
"ERRORS IN TRACE ROUTER"
End If
End Sub
Public Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
'when the socket version returned == version
'required, return True
SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS
End Function
Public Function GetIPFromAddress(Address As Long) As String
Dim ptrString As Long
ptrString = inet_ntoa(Address)
GetIPFromAddress = GetStrFromPtrA(ptrString)
End Function
Public Function GetStrFromPtrA(ByVal lpszA As Long) As String
GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
End Function
Post by MikeMHi,
I would like to query Win32_PingStatus to trace route an address.
I already use the Win32_PingStatus for pinging an address. and I have the
coding for it But I can not find any sample code for Trace Route.
I thank you in advance.