'改良了下 '原来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:windowssystem32ping.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 (编辑:李大同)
【声明】本站内容均来自网络,其相关言论仅代表作者个人观点,不代表本站立场。若无意侵犯到您的权利,请及时与联系站长删除相关内容!
|