frmtrace.frm

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

VERSION 5.00
Begin VB.Form frmtrace 
   BackColor       =   &H00000000&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Trace Route"
   ClientHeight    =   6600
   ClientLeft      =   1965
   ClientTop       =   1380
   ClientWidth     =   7425
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   6600
   ScaleWidth      =   7425
   Begin VB.TextBox txttrace 
      Height          =   285
      Left            =   1800
      TabIndex        =   9
      Top             =   240
      Width           =   4695
   End
   Begin VB.CheckBox Check1 
      BackColor       =   &H80000003&
      Caption         =   "Resolving To Hostname"
      Height          =   375
      Left            =   3720
      TabIndex        =   8
      Top             =   1200
      Width           =   2775
   End
   Begin VB.ListBox List1 
      Height          =   4020
      Left            =   600
      TabIndex        =   7
      Top             =   2280
      Width           =   495
   End
   Begin VB.TextBox Text4 
      Height          =   4215
      Left            =   1320
      MultiLine       =   -1  'True
      TabIndex        =   6
      Top             =   2280
      Width           =   5775
   End
   Begin VB.TextBox Text3 
      Height          =   285
      Left            =   1920
      TabIndex        =   5
      Top             =   1680
      Width           =   1095
   End
   Begin VB.TextBox Text2 
      Height          =   285
      Left            =   1920
      TabIndex        =   4
      Top             =   1200
      Width           =   1095
   End
   Begin VB.TextBox Text1 
      Height          =   285
      Left            =   1800
      Locked          =   -1  'True
      TabIndex        =   3
      Top             =   720
      Width           =   4695
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Trace Route"
      Height          =   375
      Left            =   3720
      Style           =   1  'Graphical
      TabIndex        =   0
      Top             =   1800
      Width           =   2775
   End
   Begin VB.Label Label4 
      Caption         =   "Char Per Packet:"
      Height          =   255
      Left            =   240
      TabIndex        =   11
      Top             =   1680
      Width           =   1455
   End
   Begin VB.Label Label1 
      Caption         =   "Number Of Packets:"
      Height          =   255
      Left            =   240
      TabIndex        =   10
      Top             =   1200
      Width           =   1455
   End
   Begin VB.Label Label3 
      Caption         =   "Resolving IP"
      Height          =   255
      Left            =   240
      TabIndex        =   2
      Top             =   720
      Width           =   1455
   End
   Begin VB.Label Label2 
      Caption         =   "Trace Route TO"
      Height          =   255
      Left            =   240
      TabIndex        =   1
      Top             =   240
      Width           =   1455
   End
End
Attribute VB_Name = "frmtrace"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' by nima bagheri form  [e-mail]
'TEL [phone]



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
Private 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


Private 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


Private 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


Private 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" _
  (ByVal VersionReq As Long, _
   WSADataReturn As WSADATA) As Long
  
Private Declare Function WSACleanup Lib "wsock32" () As Long

Private Declare Function inet_addr Lib "wsock32" _
  (ByVal s As String) As Long

Private Declare Function gethostbyaddr Lib "wsock32" _
  (haddr As Long, _
   ByVal hnlen As Long, _
   ByVal addrtype As Long) As Long
  
Private Declare Function gethostname Lib "wsock32" _
   (ByVal szHost As String, _
    ByVal dwHostLen As Long) As Long
    
Private Declare Function gethostbyname Lib "wsock32" _
   (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" _
   (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
  
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long

Private Declare Function IcmpCloseHandle Lib "icmp.dll" _
   (ByVal IcmpHandle As Long) As Long
    
Private 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
    


Private Sub Form_Load()

   Text1.Text = ""
   Text4.Text = ""
   
   ReDim TabArray(0 To 3) As Long
   
   TabArray(0) = 30
   TabArray(1) = 54
   TabArray(2) = 105
   TabArray(3) = 182
   
  'Clear existing tabs
  'and set the text tabstops
   Call SendMessage(Text4.hwnd, EM_SETTABSTOPS, 0&, ByVal 0&)
   Call SendMessage(Text4.hwnd, EM_SETTABSTOPS, 4&, TabArray(0))
   Text4.Refresh

End Sub


Private Sub Command1_Click()
   
   Command1.Enabled = False
   Call TraceRT
   Command1.Enabled = True
   
End Sub


Private Function TraceRT()

   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
   Text1.Text = ""  'the target IP
   Text2.Text = "1" 'force the no of packets = 1 for a tracert
   Text4.Text = ""  'clear the output window
   List1.Clear      'for info/debuging only
   
  'the chars per packet - can be between 32 and 128
   If IsNumeric(Text3.Text) Then
      If Val(Text3.Text) < 32 Then Text3.Text = "32"
      If Val(Text3.Text) > 128 Then Text3.Text = "128"
   Else
      Text3.Text = "32"
   End If
   
   nChrsPerPacket = Val(Text3.Text)
   
   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(txttrace.Text)
    
     '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
         Text1.Text = sAddress
         Text4.Text = "Tracing Route to " & _
                      txttrace.Text & _