form1.frm

简单的ping和trace程序

    Host = String(64, &H0)          ' Set Host value to a bunch of spaces
    
    If gethostname(Host, HostLen) = SOCKET_ERROR Then     ' This routine is where we get the host's name
        sMsg = "WSock32 Error" & Str$(WSAGetLastError())  ' If WSOCK32 error, then tell me about it
        MsgBox sMsg, vbOKOnly, "VB4032-ICMPEcho"
    Else
        Host = Left$(Trim$(Host), Len(Trim$(Host)) - 1)   ' Trim up the results
        Text1.Text = Host                                 ' Display the host's name in label1
    End If

End Sub

Sub vbIcmpSendEcho()

    Dim NbrOfPkts As Integer

    szBuffer = "abcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklm"

    If IsNumeric(Text5.Text) Then
        If Val(Text5.Text) < 32 Then Text5.Text = "32"
        If Val(Text5.Text) > 128 Then Text5.Text = "128"
    Else
        Text5.Text = "32"
    End If

    szBuffer = Left$(szBuffer, Val(Text5.Text))

    If IsNumeric(Text4.Text) Then
        If Val(Text4.Text) < 1 Then Text4.Text = "1"
    Else
        Text4.Text = "1"
    End If

    If TraceRT = True Then Text4.Text = "1"

    For NbrOfPkts = 1 To Trim$(Text4.Text)

        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        ' I hate it when this happens.  If I get an ICMP timeout
                    ' during a TRACERT, try again.

            If TraceRT Then
                TTL = TTL - 1
            Else    ' Don't worry about trying again on a PING, just timeout
                Text3.Text = Text3.Text + "ICMP Request Timeout" + Chr$(13) + Chr$(10)
            End If

        End If

    Next NbrOfPkts

End Sub

Sub vbWSAStartup()
    
    ' Subroutine to Initialize WSock32

    iReturn = WSAStartup(&H101, WSAdata)

    If iReturn <> 0 Then    ' If WSock32 error, then tell me about it
        MsgBox "WSock32.dll is not responding!", vbOKOnly, "VB4032-ICMPEcho"
    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, vbOKOnly, "VB4032-ICMPEcho"
        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, vbOKOnly, "VB4032-ICMPEcho"
        End
    End If
    
    MaxSockets = WSAdata.iMaxSockets

    '  WSAdata.iMaxSockets is an unsigned short, so we have to convert it to a signed long

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

    MaxUDP = WSAdata.iMaxUdpDg
    If MaxUDP < 0 Then
        MaxUDP = 65536 + MaxUDP
    End If

    '  Process the Winsock Description information
 
    Description = ""

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

    '  Process the Winsock Status information

    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
Function HiByte(ByVal wParam As Integer)

    HiByte = wParam \ &H100 And &HFF&

End Function
Function LoByte(ByVal wParam As Integer)

    LoByte = wParam And &HFF&

End Function
Sub vbWSACleanup()

    ' Subroutine to perform WSACleanup

    iReturn = WSACleanup()

    If iReturn <> 0 Then       ' If WSock32 error, then tell me about it.
        sMsg = "WSock32 Error - " & Trim$(Str$(iReturn)) & " occurred in Cleanup"
        MsgBox sMsg, vbOKOnly, "VB4032-ICMPEcho"
        End
    End If

End Sub

Sub vbIcmpCloseHandle()
  
    bReturn = IcmpCloseHandle(hIP)
    
    If bReturn = False Then
        MsgBox "ICMP Closed with Error", vbOKOnly, "VB4032-ICMPEcho"
    End If

End Sub

Sub vbIcmpCreateFile()

    hIP = IcmpCreateFile()

    If hIP = 0 Then
        MsgBox "Unable to Create File Handle", vbOKOnly, "VBPing32"
    End If

End Sub
Private Sub Command1_Click()

    vbWSAStartup               ' Initialize Winsock

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

    If Text1.Text = "" Then
        MsgBox "No Hostname Specified!", vbOKOnly, "VB4032-ICMPEcho"    ' Complain if No Host Name Identified
        vbWSACleanup
        Exit Sub
    End If

    vbGetHostByName            ' Get the IPAddress for the Host

    vbIcmpCreateFile           ' Get ICMP Handle

    ' The following determines the TTL of the ICMPEcho

    If IsNumeric(Text2.Text) Then
        If (Val(Text2.Text) > 255) Then Text2.Text = "255"
        If (Val(Text2.Text) < 2) Then Text2.Text = "2"
    Else
        Text2.Text = "255"
    End If

    pIPo.TTL = Trim$(Text2.Text)

    vbIcmpSendEcho             ' Send the ICMP Echo Request

    vbIcmpCloseHandle          ' Close the ICMP Handle

    vbWSACleanup               ' Close Winsock

End Sub

Private Sub Command2_Click()

    Text3.Text = ""

End Sub

Private Sub Command3_Click()

    Text3.Text = ""

    vbWSAStartup               ' Initialize Winsock

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

    If Text1.Text = "" Then
        MsgBox "No Hostname Specified!", vbOKOnly, "VB4032-ICMPEcho"    ' Complain if No Host Name Identified
        vbWSACleanup
        Exit Sub
    End If

    vbGetHostByName            ' Get the IPAddress for the Host

    vbIcmpCreateFile           ' Get ICMP Handle
    
    
    ' The following determines the TTL of the ICMPEcho for TRACE function

    TraceRT = True

    Text3.Text = Text3.Text + "Tracing Route to " + Label3.Caption + ":" + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10)

    For TTL = 2 To 255

        pIPo.TTL = TTL

        vbIcmpSendEcho             ' Send the ICMP Echo Request
        DoEvents

        If RespondingHost = Label3.Caption Then

            Text3.Text = Text3.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          ' Close the ICMP Handle

    vbWSACleanup               ' Close Winsock

End Sub

Private Sub Form_Load()

    ' I have, on many occasions, found the need to be able to perform
    ' a Ping function from within Visual Basic.  There are a few OCX
    ' Controls available on the market, however, they all require the
    ' ability for the WinSock stack to support SOCK_RAW.

    ' Microsoft does not support Raw Sockets on any of their WinSock1.1
    ' stacks.  It also appears that it will not be supported on the
    ' Winsock2.0 stack for Windows95.

    ' Raw Sockets, however, is supported on NT4.0.

    ' Microsoft, due to the lack of support of Raw Sockets, created the
    ' ICMP.DLL in order to perform basic ICMP functions such as PING and
    ' TRACERT.

    ' Well, I have finally figured out how to use the ICMP.DLL from Visual
    ' Basic.  There are not additives and no preservatives.

    ' This program is provided as is, without any warranties.  I am providing
    ' it freely.  I designed it on Windows95, however, I am sure it will work
    ' on NT3.51.  if you use portions of this code, please include some sort
    ' of reference to the author.

    ' This program was created by Jim Huff of Edinborg Productions.

    ' If you have any questions, you can reach me at:

    ' [e-mail]
    ' [e-mail]

    CenterForm

End Sub