frmtrace.frm

全面网络扫描器VB源代码 很实用

                      ":" & 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 = Text1.Text Then

              'we're done
               Text4.Text = Text4.Text & vbCrLf & _
                            "Trace Route Complete"
               Exit For

            End If

         Next ttl

        'clean up
         Call IcmpCloseHandle(hPort)
   
      Else
         MsgBox "Unable to Open an Icmp File Handle", _
                   vbOKOnly, _
                   "VBnet TraceRT Demo"
                   
      End If  'If hPort
   
     'clean up
      Call SocketsCleanup
      
   Else
      MsgBox "Unable to initialize the Windows Sockets", _
                vbOKOnly, _
                "VBnet TraceRT Demo"
                
   End If  'if SocketsInitialize()

End Function


Private 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


Private Sub SocketsCleanup()
   
  'only show error if unable to clean up the sockets
   If WSACleanup() <> 0 Then
       MsgBox "Windows Sockets error occurred during Cleanup.", vbExclamation
   End If
    
End Sub


Private 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


Private Function GetIPFromAddress(Address As Long) As String
   
   Dim ptrString As Long
   
   ptrString = inet_ntoa(Address)
   GetIPFromAddress = GetStrFromPtrA(ptrString)
   
End Function


Private Function GetStrFromPtrA(ByVal lpszA As Long) As String

   GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
   Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
   
End Function


Private Function GetHostNameFromAddress(ByVal Address As Long) As String

   Dim nbytes As Long
   Dim ptrHosent As Long  'pointer to a HOSENT structure
   Dim lookupIP As String

  'lookup by IP
   ptrHosent = gethostbyaddr(Address, 4, AF_INET)
         
   If ptrHosent <> 0 Then

     'convert address and
     'get resolved hostname
      CopyMemory ptrHosent, ByVal ptrHosent, 4
      nbytes = lstrlenA(ByVal ptrHosent)

      If nbytes > 0 Then
         lookupIP = Space$(nbytes)
         CopyMemory ByVal lookupIP, ByVal ptrHosent, nbytes
         GetHostNameFromAddress = lookupIP
      End If

   Else  'failed!
      GetHostNameFromAddress = ""
   End If

End Function


Private Sub ShowResults(timeToLive As Byte, _
                        tripTime As Long, _
                        sHostIP As String, _
                        Optional sHostName 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 = Text4.Text
   
  'create a new entry
   tmp = "Hop #" & vbTab & _
          CStr(timeToLive) & vbTab & _
          sTripTime & vbTab & _
          sHostIP
          
   If Check1.value = 1 Then
          
      tmp = tmp & vbTab & sHostName
      
   End If
          
   tmp = tmp & vbCrLf

  'update textbox
   Text4.Text = buff & tmp
   
  'yield
   DoEvents
    
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)
              
       If Check1.value = 1 Then
       
         sHostName = GetHostNameFromAddress(ECHO.Address)
       
       End If
              
       ShowResults ipo.ttl, ECHO.RoundTripTime, sHostIP, sHostName
       
      '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
      'deincremented by 1, causing the
      'for / next to retry this hop.
       TraceRTSendEcho = 1
   
   End If
        
End Function