VB模拟发送ICMP数据包(代码直接可用)

'*********************************************************************
'         程序设计 河南工业大学信息网-http://www.hautbbs.com.cn
'本站以方便在校师生信息交流为宗旨，是一个集信息传递、资料查询、娱乐交友为一体的校园网络平台!
'我站为您免费提供信息平台,您只需要注册一个通行证即可轻松拥有属于自己的网络空间,娱乐交友、发布信息等完全由你来掌控 , 就是这么简单!
'     快乐(来)问吧:http://www.huatbbs.com.cn/ask -在线解疑答惑!
'                       版权所有,改编不究
'*********************************************************************
Option Explicit
Dim HostName As String
Const SOCKET_ERROR = 0
    Dim hFile As Long, lpWSAdata As WSAdata
    Dim hHostent As Hostent, AddrList As Long
    Dim Address As Long, rIP As String
    Dim OptInfo As IP_OPTION_INFORMATION
    Dim EchoReply As IP_ECHO_REPLY
Private Type WSAdata
    wVersion As Integer
    wHighVersion As Integer
    szDescription(0 To 255) As Byte
    szSystemStatus(0 To 128) As Byte
    '快乐(来)问吧:http://www.huatbbs.com.cn/ask -在线解疑答惑!
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type
Private Type Hostent
    h_name As Long
    h_aliases As Long
    h_addrtype As Integer
    h_length As Integer
    h_addr_list As Long
End Type
Private Type IP_OPTION_INFORMATION
'快乐(来)问吧:http://www.huatbbs.com.cn/ask -在线解疑答惑!
    TTL As Byte
    Tos As Byte
    Flags As Byte
    OptionsSize As Long
    OptionsData As String * 128
End Type
Private Type IP_ECHO_REPLY
    Address(0 To 3) As Byte
    '快乐(来)问吧:http://www.huatbbs.com.cn/ask -在线解疑答惑!
    Status As Long
    RoundTripTime As Long
    DataSize As Integer
    Reserved As Integer
    data As Long
    Options As IP_OPTION_INFORMATION
End Type
Private Declare Function GetHostByName Lib "wsock32.dll" Alias "gethostbyname" (ByVal HostName As String) As Long
Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired&, lpWSAdata As WSAdata) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'快乐(来)问吧:http://www.huatbbs.com.cn/ask -在线解疑答惑!
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal HANDLE As Long) As Boolean
Private 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 '快乐(来)问吧:http://www.huatbbs.com.cn/ask -在线解疑答惑!

Private Sub Command1_Click()
HostName = Text2.Text
If Text2.Text = "www." Or Text2.Text = "www" Or Text2.Text = "" Then
    MsgBox "网址输入格式可能有误!", vbExclamation, "提示信息"
    '快乐(来)问吧:http://www.huatbbs.com.cn/ask -在线解疑答惑!
    Text2.SetFocus
    Else
    Me.Cls
Call WSAStartup(&H101, lpWSAdata)
    If GetHostByName(HostName + String(64 - Len(HostName), 0)) <> SOCKET_ERROR Then
        CopyMemory hHostent.h_name, ByVal GetHostByName(HostName + String(64 - Len(HostName), 0)), Len(hHostent)
        '快乐(来)问吧:http://www.huatbbs.com.cn/ask -在线解疑答惑!
        CopyMemory AddrList, ByVal hHostent.h_addr_list, 4
        CopyMemory Address, ByVal AddrList, 4
    End If
    hFile = IcmpCreateFile()
    If hFile = 0 Then
        MsgBox "无法创建文件句柄!", vbDefaultButton1, "提示信息"
        Exit Sub
    End If
    OptInfo.TTL = 255
    If IcmpSendEcho(hFile, Address, String(32, "A"), 32, OptInfo, EchoReply, Len(EchoReply) + 8, 2000) Then
    '快乐(来)问吧:http://www.huatbbs.com.cn/ask -在线解疑答惑!
        rIP = CStr(EchoReply.Address(0)) + "." + CStr(EchoReply.Address(1)) + "." + CStr(EchoReply.Address(2)) + "." + CStr(EchoReply.Address(3))
    Else
        MsgBox "返回数据包超时!", vbDefaultButton1, "提示信息"
    End If
    If EchoReply.Status = 0 Then
        Text1.Text = "Reply from " + HostName + " (" + rIP + ") recieved after " + Trim$(CStr(EchoReply.RoundTripTime)) + "ms"
    Else
        MsgBox "暂无返回数据包或其他原因!", vbDefaultButton2, "提示信息"
        '快乐(来)问吧:http://www.huatbbs.com.cn/ask -在线解疑答惑!
    End If
    Call IcmpCloseHandle(hFile)
    Call WSACleanup
    End If
End Sub

Private Sub Form_Load()
    Text2.Text = "www."
    Text2.ToolTipText = "网址格式为:www.hautbbs.com.cn"
    Form1.Caption = "河南工业大学信息网 -http://www.hautbbs.com.cn"
End Sub
'你可以自由转载,传播或修改,但请保留版权信息!
'快乐(来)问吧:http://www.huatbbs.com.cn/ask -在线解疑答惑!