'*********************************************************************
' 程序设计 河南工业大学信息网-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 -在线解疑答惑!