📄 网络测试.frm
字号:
VERSION 5.00
Begin VB.Form Form1
Caption = "网络连接测试"
ClientHeight = 2055
ClientLeft = 60
ClientTop = 345
ClientWidth = 5385
Icon = "网络测试.frx":0000
LinkTopic = "Form1"
ScaleHeight = 2055
ScaleWidth = 5385
StartUpPosition = 3 '窗口缺省
Begin VB.Frame Frame1
Height = 1755
Left = 420
TabIndex = 0
Top = 90
Width = 4545
Begin VB.TextBox Text5
Alignment = 1 'Right Justify
Height = 345
Left = 1140
TabIndex = 11
Top = 690
Width = 3165
End
Begin VB.TextBox Text4
Alignment = 2 'Center
BorderStyle = 0 'None
Height = 195
Left = 3900
TabIndex = 9
Top = 300
Width = 315
End
Begin VB.TextBox Text3
Alignment = 2 'Center
BorderStyle = 0 'None
Height = 195
Left = 3420
TabIndex = 8
Top = 300
Width = 315
End
Begin VB.TextBox Text2
Alignment = 2 'Center
BorderStyle = 0 'None
Height = 195
Left = 2880
TabIndex = 7
Top = 300
Width = 315
End
Begin VB.CommandButton Command2
Caption = "退 出"
Height = 315
Left = 3030
TabIndex = 5
Top = 1200
Width = 1305
End
Begin VB.CommandButton Command1
Caption = "下一地址"
Height = 315
Left = 1710
TabIndex = 4
Top = 1200
Width = 1305
End
Begin VB.TextBox Text1
Alignment = 2 'Center
BorderStyle = 0 'None
Height = 195
Left = 2370
TabIndex = 1
Top = 300
Width = 315
End
Begin VB.Label Label11
BackStyle = 0 'Transparent
Caption = "."
Height = 30
Left = 4200
TabIndex = 10
Top = 390
Width = 30
End
Begin VB.Label Label2
BackColor = &H80000009&
BorderStyle = 1 'Fixed Single
Caption = " . . ."
Height = 345
Left = 1140
TabIndex = 6
Top = 210
Width = 3165
End
Begin VB.Label Label3
AutoSize = -1 'True
Caption = "测试结果："
Height = 180
Left = 150
TabIndex = 3
Top = 780
Width = 900
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "IP 地址："
Height = 180
Left = 150
TabIndex = 2
Top = 270
Width = 810
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' 字符常数说明
Private Const IP_SUCCESS = 0
Private Const IP_REQ_TIMED_OUT = 11010
Private Const IP_BAD_DESTINATION = 11018
Private Const PING_TIMEOUT = 200
' 结构型变量声明
Private Type ICMP_ECHO_REPLY
Address As Long
Status As Long
RoundTripTime As Long
Reserved As Integer
Data As String * 250
End Type
' API 函数声明
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, ByVal RequestOptions As Long, ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long, ByVal Timeout As Long) As Long
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If IsNumeric(Text1) Then
If Val(Text1) < 0 Or Val(Text1) > 255 Then
MsgBox " 请输入 0 至 255 之间的数据 "
Text1 = ""
Text1.SetFocus
Else
Text2.SetFocus
End If
Else
MsgBox " 请输入数据 "
Text1 = ""
Text1.SetFocus
End If
End If
End Sub
Private Sub Text2_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If IsNumeric(Text2) Then
If Val(Text2) < 0 Or Val(Text2) > 255 Then
MsgBox " 请输入 0 至 255 之间的数据 "
Text2 = ""
Text2.SetFocus
Else
Text3.SetFocus
End If
Else
MsgBox " 请输入数据 "
Text2 = ""
Text2.SetFocus
End If
End If
End Sub
Private Sub Text3_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If IsNumeric(Text3) Then
If Val(Text3) < 0 Or Val(Text3) > 255 Then
MsgBox " 请输入 0 至 255 之间的数据 "
Text3 = ""
Text3.SetFocus
Else
Text4.SetFocus
End If
Else
MsgBox " 请输入数据 "
Text3 = ""
Text3.SetFocus
End If
End If
End Sub
Private Sub Text4_KeyPress(KeyAscii As Integer)
Dim Echo As ICMP_ECHO_REPLY, Add As String
Dim pos As Integer
If KeyAscii = 13 Then
If IsNumeric(Text4) Then
If Val(Text4) < 0 Or Val(Text4) > 255 Then
MsgBox " 请输入 0 至 255 之间的数据 "
Text4 = ""
Text4.SetFocus
Else
Add = Text1 & "." & Text2 & "." & Text3 & "." & Text4
Call Ping(Add, Echo)
Text5 = GetStatusCode(Echo.Status)
Command1.SetFocus
End If
Else
MsgBox " 请输入数据 "
Text4 = ""
Text4.SetFocus
End If
End If
End Sub
Private Sub Command1_Click()
Text1 = "": Text2 = "": Text3 = ""
Text4 = "": Text5 = ""
Text1.SetFocus
End Sub
Private Sub Command2_Click()
Unload Me
End
End Sub
Private Function Ping(szAddress As String, Echo As ICMP_ECHO_REPLY) As Long
Dim hPort As Long
Dim dwAddress As Long
Dim sDataToSend As String
sDataToSend = ""
dwAddress = AddressStringToLong(szAddress)
hPort = IcmpCreateFile()
If IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), 0, Echo, Len(Echo), PING_TIMEOUT) Then
Ping = Echo.RoundTripTime
Else
Ping = -Echo.Status
End If
Call IcmpCloseHandle(hPort)
End Function
Function AddressStringToLong(ByVal Tmp As String) As Long
Dim Parts(1 To 4) As String, I As Integer
I = 0
While InStr(Tmp, ".") > 0
I = I + 1
Parts(I) = Mid(Tmp, 1, InStr(Tmp, ".") - 1)
Tmp = Mid(Tmp, InStr(Tmp, ".") + 1)
Wend
I = I + 1
Parts(I) = Tmp
If I <> 4 Then
AddressStringToLong = 0
Exit Function
End If
AddressStringToLong = Val("&H" & Right("00" & Hex(Parts(4)), 2) & Right("00" & Hex(Parts(3)), 2) & Right("00" & Hex(Parts(2)), 2) & Right("00" & Hex(Parts(1)), 2))
End Function
Private Function GetStatusCode(Status As Long) As String
Dim msg As String
Select Case Status
Case IP_SUCCESS: msg = "测试成功"
Case IP_REQ_TIMED_OUT: msg = "测试失败"
Case IP_BAD_DESTINATION: msg = "测试失败"
Case Else:
End Select
GetStatusCode = msg
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -