vb实现ping

 

'改良了下
'原来4秒刷一次，现在0.3秒刷一次
'现在只返回毫秒了
'你是不是为了玩山口山啊？
'2个TextBox :
 Text1   - 输入ip
 Text2   - 显示结果
'1个Timer         : Timer1
'1个CommandButton : Command1
Option Explicit

Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const STARTF_USESTDHANDLES = &H100&
Private Const STARTF_USESHOWWINDOW = &H1

Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type

Private Type STARTUPINFO
cb As Long
lpReserved As Long
lpDesktop As Long
lpTitle As Long
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type

Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type

Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
Const FLAG = SWP_NOMOVE Or SWP_NOSIZE
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const HWND_TOP = 0
Const HWND_BOTTOM = 1

Dim Proc As PROCESS_INFORMATION '进程信息
Dim Start As STARTUPINFO '启动信息
Dim SecAttr As SECURITY_ATTRIBUTES '安全属性
Dim hReadPipe As Long '读取管道句柄
Dim hWritePipe As Long '写入管道句柄
Dim lngBytesRead As Long '读出数据的字节数
Dim strBuffer As String * 256 '读取管道的字符串buffer
Dim Command As String 'DOS命令
Dim ret As Long 'API函数返回值

Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, _
ByVal y As Long, ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) As Long

Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As SECURITY_ATTRIBUTES, ByVal nSize As Long) As Long
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As String, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Sub Command1_Click()

If Not InitPipe Then
    Exit Sub
Else
    'init
    Dim s As String
   
    s = ReadPipe
    'Me.Text2.Text = s
    Me.Timer1.Enabled = True
End If
End Sub

Private Sub Form_Load()
Call SetWindowPos(Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAG)
Me.Command1.Caption = "Start"
Me.Timer1.Enabled = False
Me.Timer1.Interval = 300
Me.Text1.Text = "222.210.27.114"
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
ClosePipe
End Sub

Private Sub Timer1_Timer()

Dim strPipe As String

On Error Resume Next

strPipe = ReadPipe()

If Len(strPipe) > 0 Then
If InStr(1, strPipe, "time") > 0 Then

Dim lPosStart As Long
Dim lPosEnd As Long
Dim sMS As String

lPosStart = InStr(strPipe, "time=")
lPosEnd = InStr(strPipe, "ms")

sMS = Mid(strPipe, lPosStart + 5, lPosEnd - lPosStart - 5)

'Text2.Text = Now & "==============>" & vbCrLf & strPipe & vbCrLf & Text2.Text
Text2.Text = sMS & vbCrLf & Text2.Text
End If
End If

 
End Sub

Private Function InitPipe() As Boolean

'设置安全属性
With SecAttr
.nLength = LenB(SecAttr)
.bInheritHandle = True
.lpSecurityDescriptor = 0
End With

'创建管道
ret = CreatePipe(hReadPipe, hWritePipe, SecAttr, 0)
If ret = 0 Then
MsgBox "无法创建管道", vbExclamation, "错误"
GoTo ErrHdr
End If

'设置进程启动前的信息
With Start
.cb = LenB(Start)
.dwFlags = STARTF_USESHOWWINDOW Or STARTF_USESTDHANDLES
.hStdOutput = hWritePipe '设置输出管道
.hStdError = hWritePipe '设置错误管道
End With

'启动进程
Command = "c:\windows\system32\ping.exe  -t " & Me.Text1.Text  'DOS进程以ipconfig.exe为例
ret = CreateProcess(vbNullString, Command, SecAttr, SecAttr, True, NORMAL_PRIORITY_CLASS, ByVal 0, vbNullString, Start, Proc)
If ret = 0 Then
MsgBox "无法启动新进程", vbExclamation, "错误"
ret = CloseHandle(hWritePipe)
ret = CloseHandle(hReadPipe)
GoTo ErrHdr
End If

If False Then
ErrHdr:
InitPipe = False
Exit Function
End If
InitPipe = True
End Function

Private Function ReadPipe() As String

Dim lpOutputs As String

'因为无需写入数据，所以先关闭写入管道。而且这里必须关闭此管道，否则将无法读取数据
ret = CloseHandle(hWritePipe)

'从输出管道读取数据，每次最多读取256字节

ret = ReadFile(hReadPipe, strBuffer, 256, lngBytesRead, ByVal 0)
lpOutputs = lpOutputs & Left(strBuffer, lngBytesRead)
 

ReadPipe = lpOutputs
End Function

Private Sub ClosePipe()
On Error Resume Next
'读取操作完成，关闭各句柄
ret = CloseHandle(Proc.hProcess)
ret = CloseHandle(Proc.hThread)
ret = CloseHandle(hReadPipe)
End Sub

 

 

 

 

 

 

 

**************************************************

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub Command1_Click()
    Dim i As Integer
    Dim q As String
    Shell "cmd.exe /c ping 10.2.31.1 -t > c:\1.txt", vbHide
    On Error Resume Next
    For i = 1 To 100
        List1.Clear
        Open "c:\1.txt" For Input As #1
            If Err.Number = 0 Then
                While Not EOF(1)
                    Line Input #1, q
                    If Trim(q) <> "" Then List1.AddItem q ' Text1.Text = Text1.Text & vbCrLf & q
                Wend
            End If
        Close #1
        Err.Clear
        DoEvents
        Sleep 500
    Next i
    Kill "c:\1.txt"

End Sub