Ping using VB

 

'Improved
'The original 4 seconds, now 0.3 seconds
'Now only milliseconds are returned.
'If you want to play with Yamaguchi?
'2 textbox:
Text1-input IP Address
Text2-display result
'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 'Process Information
Dim start as startupinfo' startup information
Dim secattr as security_attributes 'security attributes
Dim hreadpipe as long 'read pipe handle
Dim hwritepipe as long' write pipeline handle
Dim lngbytesread as long 'number of bytes of data read
Dim strbuffer as string * 256 'read the string buffer of the Pipeline
Dim command as string 'dos command
Dim RET as long' API function return value

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, region as Alias, byval binherithandles as long,
Byval dwcreationflags as long, lpenvironment as any, byval maid 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 commandementclick ()

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

'Set security attributes
With secattr
. Nlength = lenb (secattr)
. Binherithandle = true
. Lpsecuritydescriptor = 0
End

'Create an MPS queue
Ret = createpipe (hreadpipe, hwritepipe, secattr, 0)
If ret = 0 then
Msgbox "cannot create MPs queue", vbexclamation, "error"
Goto errhdr
End if

'Sets the information before the process starts.
With start
. Cb = lenb (start)
. Dwflags = startf_useshowwindow or startf_usestdhandles
. Hstdoutput = hwritepipe 'sets the output Pipeline
. Hstderror = hwritepipe 'sets the error MPs queue.
End

'Start the process
Command = "C: \ windows \ system32 \ ping.exe-T" & me. text1.text 'dos takes ipconfig.exe as an Example
Ret = CreateProcess (vbnullstring, command, secattr, secattr, true, normal_priority_class, byval 0, vbnullstring, start, Proc)
If ret = 0 then
Msgbox "failed to start new processes", vbexclamation, "error"
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

'Because no data needs to be written, the writing pipeline is closed first. In addition, you must disable this MPs queue. Otherwise, data cannot be read.
Ret = closehandle (hwritepipe)

'The data is read from the output pipeline. A maximum of 256 bytes can be read each time.

Ret = readfile (hreadpipe, strbuffer, 256, lngbytesread, byval 0)
Lpoutputs = lpoutputs & left (strbuffer, lngbytesread)
 

Readpipe = lpoutputs
End Function

Private sub closepipe ()
On Error resume next
'The read operation is complete. Close the handles.
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 commandementclick ()
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 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