vb ping 计算机名称,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,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,True,NORMAL_PRIORITY_CLASS,ByVal 0,vbNullString,Start,Proc)

If ret = 0 Then

MsgBox "无法启动新进程","错误"

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

总结

以上是编程之家为你收集整理的vb实现ping全部内容，希望文章能够帮你解决vb实现ping所遇到的程序开发问题。

如果觉得编程之家网站内容还不错，欢迎将编程之家网站推荐给程序员好友。

本图文内容来源于网友网络收集整理提供，作为学习参考使用，版权属于原作者。