vbicmp.bas

功能强大的API

Attribute VB_Name = "vbICMP"
' Eliminated the global variables from the vbICMP.BAS files on 11/19/97.  Also, I consolidated
' what was the vbIcmpCreateFile() and vbIcmpCloseFile() function calls into the vbIcmpSendEcho()
' function.  Now we only have two vb Functions...vbIcmpSendEcho() & vbGetRCode().
' JimHuff

' ICMP UDT's

Type IP_OPTION_INFORMATION
    TTL As Byte                   ' Time to Live (used for traceroute)
    Tos As Byte                   ' Type of Service (usually 0)
    Flags As Byte                 ' IP header Flags (usually 0)
    OptionsSize As Long           ' Size of Options data (usually 0, max 40)
    OptionsData As String * 128   ' Options data buffer
End Type

Public pIPo As IP_OPTION_INFORMATION

Type IP_ECHO_REPLY
    Address(0 To 3) As Byte           ' Replying Address
    Status As Long                    ' Reply Status
    RoundTripTime As Long             ' Round Trip Time in milliseconds
    DataSize As Integer               ' reply data size
    Reserved As Integer               ' for system use
    data As Long                      ' pointer to echo data
    Options As IP_OPTION_INFORMATION  ' Reply Options
End Type

Public pIPe As IP_ECHO_REPLY

' ICMP Subroutines and Functions

    ' IcmpCreateFile will return a file handle
    
Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
     
     ' Pass the handle value from IcmpCreateFile to the IcmpCloseHandle.  It will return
     ' a boolean value indicating whether or not it closed successfully.
     
Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal HANDLE As Long) As Boolean

    ' IcmpHandle returned from IcmpCreateFile
    ' DestAddress is a pointer to the first entry in the hostent.h_addr_list
    ' RequestData is a null-terminated 64-byte string filled with ASCII 170 characters
    ' RequestSize is 64-bytes
    ' RequestOptions is a NULL at this time
    ' ReplyBuffer
    ' ReplySize
    ' Timeout is the timeout in milliseconds

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
Function vbGetRCode(iStatus As Long) As String

    Select Case iStatus
        Case 0
            vbGetRCode = "Success"
        Case 11001
            vbGetRCode = "Buffer too Small"
        Case 11002
            vbGetRCode = "Dest Network Not Reachable"
        Case 11003
            vbGetRCode = "Dest Host Not Reachable"
        Case 11004
            vbGetRCode = "Dest Protocol Not Reachable"
        Case 11005
            vbGetRCode = "Dest Port Not Reachable"
        Case 11006
            vbGetRCode = "No Resources Available"
        Case 11007
            vbGetRCode = "Bad Option"
        Case 11008
            vbGetRCode = "Hardware Error"
        Case 11009
            vbGetRCode = "Packet too Big"
        Case 11010
            vbGetRCode = "Rqst Timed Out"
        Case 11011
            vbGetRCode = "Bad Request"
        Case 11012
            vbGetRCode = "Bad Route"
        Case 11013
            vbGetRCode = "TTL Exprd in Transit"
        Case 11014
            vbGetRCode = "TTL Exprd Reassemb"
        Case 11015
            vbGetRCode = "Parameter Problem"
        Case 11016
            vbGetRCode = "Source Quench"
        Case 11017
            vbGetRCode = "Option too Big"
        Case 11018
            RCode = " Bad Destination"
        Case 11019
            RCode = "Address Deleted"
        Case 11020
            RCode = "Spec MTU Change"
        Case 11021
            RCode = "MTU Change"
        Case 11022
            RCode = "Unload"
        Case 11050
            RCode = "General Failure"

    End Select

End Function
Function vbIcmpSendEcho(IPAddress As String, TTL As Integer, TimeOut As Integer) As String

' This function call was modified on August 25, 1998 to include the Timeout Parameter.
' The TimeOut parameter is used to determine the time (in seconds) which the function
' will wait for an ICMPEchoReply to occur.  If the reply is not received within the time
' specified this function will return "****  ICMP Request Timeout   ****"

' Pass this function call the Dotted-Decimal IP Address, along with the TimeToLive
' and vbIcmpSendEcho will return the response as a string

    ' EXAMPLE:

    ' Dim Response as String
    ' Response=vbIcmpSendEcho("204.111.12.65", 255)

' Function vbIcmpSendEcho(IPAddress As String, TTL As Integer) As String

' The function call was originally formatted as the above remarked line, however, I
' removed the NbrOfPackets variable and added the IPAddress variable in its place.

' NbrOfPackets served no function.  It was once used to loop through
' the ping routine at the module level, however, it seemed to me that the calling
' routine should perform this function instead.  Jim Huff (11/19//97)

' In order to do the TraceRT function, all you need to do is start with a TTL of 1 and
' work your way up, until you get a response from the desired host, instead of intermediary
' hops.

    Dim bReturn As Boolean
    Dim szBuffer As String
    Dim RCode As String
    Dim RespondingHost As String
    Dim hIP As Long                 ' The handle for ICMP.DLL

    ' Convert the TimeOut value to milliseconds

    TimeOut = TimeOut * 1000

    ' Open the ICMP.DLL

    hIP = IcmpCreateFile()

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

    Dim addr As Long                ' Added 11/19/97 JimHuff.  Was originally a Global

    addr = vbInet_Addr(IPAddress)   ' Convert the IPAddress from a Dotted-Decimal IP
                                    ' Address to a long.

    szBuffer = "abcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqr"

    pIPo.TTL = TTL
    pIPo.Tos = 8

    ' NOTE:  The addr variable below is obtained in the vbGetHostByName function call.

    bReturn = IcmpSendEcho(hIP, addr, szBuffer, Len(szBuffer), pIPo, pIPe, Len(pIPe) + 8, TimeOut)

    If bReturn Then

        RespondingHost = ""

        ' The following line converts from a u_long IP Address to a Dotted-Decimal IP Address

        RespondingHost = CStr(pIPe.Address(0)) + "." + CStr(pIPe.Address(1)) + "." + CStr(pIPe.Address(2)) + "." + CStr(pIPe.Address(3))

        ' You can modify the following in order to return the desired response that you wish
        ' to receive upon returning from this function call.

        If pIPe.Status = 0 Then
            ' No Error Was Encountered.  The response can be modified to suit your needs.
            vbIcmpSendEcho = " 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
            ' An Error Was Encountered.  I modified this line for the response code.  11/19/97 JimHuff
            vbIcmpSendEcho = " Reply from " + RespondingHost + ": " + vbGetRCode(pIPe.Status) + " (" + CStr(pIPe.Status) + ")" + Chr$(13) + Chr$(10)
        End If

    Else

        ' A Timeout has occurred

        vbIcmpSendEcho = "****  ICMP Request Timeout   ****" + Chr$(13) + Chr$(10)

    End If

    ' Now to close the ICMP.DLL

    bReturn = IcmpCloseHandle(hIP)

    If bReturn = False Then
        MsgBox "ICMP Closed with Error", vbOKOnly, "ICMP Error"
    End If

End Function