说明：不是调用cmd命令ping，完全是内置的。

用法：PingIP("202.108.22.142", TTL(可选,默认10), TimeOut(可选,默认1000))，返回延时时长

注意：不能ping域名。

可自定义TTL和超时时间。

这个是改国外的，原版超级啰嗦。给精简了。

原作者是谁已不得而知。

以下是Ping 模块代码：

Option Explicit
'Ping 模块，用法：PingIP("202.108.22.142", TTL(可选,默认10), TimeOut(可选,默认1000))，返回延时时长
'注意：不能ping域名。

Private Type ip_option_information
    TTL As Byte 'Time To Live
    Tos As Byte 'Type Of Service
    Flags As Byte 'IP header flags
    OptionsSize As Byte 'Size in bytes of options data
    OptionsData As Long 'Pointer to options data
End Type

Private Type icmp_echo_reply
    Address As Long 'Replying address
    Status As Long 'Reply IP_STATUS, values as defined above
    RoundTripTime As Long 'RTT in milliseconds
    DataSize As Integer 'Reply data size in bytes
    Reserved As Integer 'Reserved for system use
    DataPointer As Long 'Pointer to the reply data
    Options As ip_option_information 'Reply options
    Data As String * 250 'Reply data which should be a copy of the string sent, NULL terminated
    'this field length should be large enough to contain the string sent
End Type

Private CurIp As Long
Private CurIpDes As String
Private Const WSADESCRIPTION_LEN = 256
Private Const WSASYSSTATUS_LEN = 256
Private Const WSADESCRIPTION_LEN_1 = WSADESCRIPTION_LEN + 1
Private Const WSASYSSTATUS_LEN_1 = WSASYSSTATUS_LEN + 1
Private Const SOCKET_ERROR = -1

Private Type tagWSAData
    wVersion As Integer
    wHighVersion As Integer
    szDescription As String * WSADESCRIPTION_LEN_1
    szSystemStatus As String * WSASYSSTATUS_LEN_1
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As String * 200
End Type

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 Integer, RequestOptions As ip_option_information, ReplyBuffer As icmp_echo_reply, ByVal ReplySize As Long, ByVal TimeOut As Long) As Long
Private Declare Function WSAStartup Lib "wsock32" (ByVal wVersionRequested As Integer, lpWSADATA As tagWSAData) As Integer
Private Declare Function WSACleanup Lib "wsock32" () As Integer
Public Function PingIP(ByVal strIPAddress As String, Optional ByVal lngTTL As Long = 10, Optional ByVal lngTimeOut As Long = 1000) As String
Dim hFile As Long 'handle for the icmp port opened
Dim lRet As Long 'hold return values as required
Dim lIPAddress As Long
Dim strMessage As String
Dim pOptions As ip_option_information
Dim pReturn As icmp_echo_reply
Dim iVal As Integer
Dim lPingRet As Long
Dim pWsaData As tagWSAData

strMessage = "Echo this string of data"
iVal = WSAStartup(&H101, pWsaData)
ConvertIPAddressToLong strIPAddress
lIPAddress = CurIp
hFile = IcmpCreateFile()
pOptions.TTL = lngTTL
lRet = IcmpSendEcho(hFile, lIPAddress, strMessage, Len(strMessage), pOptions, pReturn, Len(pReturn), lngTimeOut)

If lRet = 0 Then
    PingIP = "Fail"
Else
    If pReturn.Status <> 0 Then
        PingIP = "Fail"
    Else
        PingIP = pReturn.RoundTripTime & "ms"
    End If
    If pReturn.RoundTripTime > lngTimeOut Then
        PingIP = "TimeOut"
    End If
End If

lRet = IcmpCloseHandle(hFile)
iVal = WSACleanup()
End Function
Private Sub ConvertIPAddressToLong(ByVal strIPAddress As String)
On Error Resume Next
Dim strTemp As String, lAddress As Long, iValCount As Integer, lDotValues(1 To 4) As String

strTemp = strIPAddress '建立初始储存和计数器
iValCount = 0

Do While InStr(strTemp, ".") > 0 'keep going while we still have dots in the string
    iValCount = iValCount + 1 'count the number
    lDotValues(iValCount) = Mid(strTemp, 1, InStr(strTemp, ".") - 1) 'pick it off and convert it
    strTemp = Mid(strTemp, InStr(strTemp, ".") + 1) 'chop off the number and the dot
Loop

iValCount = iValCount + 1 'the string only has the last number in it now
lDotValues(iValCount) = strTemp

If iValCount <> 4 Then 'if we didn't get four pieces then the IP address is no good
    CurIp = 0
    Exit Sub
End If

'take the four value, hex them, pad to 2 digits, make a hex string and then convert the whole mess to a long for returning
lAddress = Val("&H" & Right("00" & Hex(lDotValues(4)), 2) & Right("00" & Hex(lDotValues(3)), 2) & Right("00" & Hex(lDotValues(2)), 2) & Right("00" & Hex(lDotValues(1)), 2))

CurIp = lAddress '设置返回值
CurIpDes = strIPAddress
End Sub