سورس کد پینگ (ویژوال بیسیک 6)

کد:
Option Explicit 

Const SYNCHRONIZE = &H100000 

Const INFINITE = &HFFFF 

Const WAIT_OBJECT_0 = 0 

Const WAIT_TIMEOUT = &H102 

Dim stopflag As Boolean 

Dim errorflag As Boolean 

Dim mindelay As Integer 

Dim maxdelay As Integer 

Dim totaldelay As Long 

Dim avgdelay As Integer 

Dim lcount As Long 

Dim pingMessage(26) As String 

Dim ctrl 

Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long 

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long 

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long 

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long 

Private Sub cmdClear_Click() 

Open "C:\log.txt" For Output As #1 

Close #1 

txtoutput.Text = "" 

txtpinglog.Text = "" 

End Sub 

Private Sub chklog_Click() 

End Sub 

Private Sub cmdExit_Click() 

Unload Me 

End 

End Sub 

Private Sub cmdlog_Click() 

Load frmlog 

frmlog.Show 1 

End Sub 

Private Sub cmdPing_Click() 

DoEvents 

If cmdPing.Caption = "Ping" Then 

lblstatus.Caption = "Pinging " & txtIP.Text & " with " & txtbuffer.Text & "KB of data" 

txtIP.Locked = True 

cmdPing.BackColor = &HFF& 

cmdlog.Enabled = False 

cmdPing.Caption = "Stop" 

stopflag = False 

Else 

stopflag = True 

cmdPing.Caption = "Ping" 

txtIP.Locked = False 

cmdPing.BackColor = &H80FF80 

cmdlog.Enabled = True 

lblstatus.Caption = "Stopped" 

End If 



While stopflag = False 

DoEvents 



Dim ShellX As String 

Dim lPid As Long 

Dim lHnd As Long 

Dim lRet As Long 

Dim VarX As String 

Dim Ptime As Integer 

Dim pttl As Integer 

Dim pbyte As Integer 

Dim i As Integer 

Dim pingresult As String 

Dim tmin As Integer 

Dim tmax As Integer 

Dim tavg As Integer 



If txtIP.Text <> "" Then 

DoEvents 

ShellX = Shell("command.com /c ping -n 1 -l " & txtbuffer.Text & " " & txtIP.Text & " > C:\log.txt", vbHide) 

lPid = ShellX 

If lPid <> 0 Then 

lHnd = OpenProcess(SYNCHRONIZE, 0, lPid) 

If lHnd <> 0 Then 

lRet = WaitForSingleObject(lHnd, INFINITE) 

CloseHandle (lHnd) 

End If 



frmmain.MousePointer = 0 

Open "C:\log.txt" For Input As #1 

txtoutput.Text = Input(LOF(1), 1) 



pingresult = Trim(Mid(txtoutput.Text, InStr(1, txtoutput.Text, ":") + 1, Len(txtoutput.Text) - (InStr(1, txtoutput.Text, ":") + Len(Mid(txtoutput.Text, InStr(1, txtoutput.Text, "Ping ")))))) 



'check for error 

If InStr(1, pingresult, "Reply") = 0 Then 

Dim message As String 

If InStr(1, pingresult, "Hardware") <> 0 Then 

message = "HARDWARE FAULT" 

Else 

If InStr(1, pingresult, "Request") <> 0 Then 

message = "Request time out" 

Else 

If InStr(1, pingresult, "Destination") <> 0 Then 

message = "Destination Computer is not reachable" 

Else 

message = pingresult 

End If 



End If 

End If 

pingresult = "ERROR with " & txtIP.Text & ":" & message 





'pingmessage 

txtpinglog.Text = "" 

For i = 0 To 22 

pingMessage(i) = pingMessage(i + 1) 

If pingMessage(i + 1) <> "" Then 

If txtpinglog.Text <> "" Then 

txtpinglog.Text = txtpinglog.Text & vbCrLf 

End If 

txtpinglog.Text = txtpinglog.Text & pingMessage(i + 1) 

End If 

Next 



pingMessage(23) = pingresult 

If txtpinglog.Text <> "" Then 

txtpinglog.Text = txtpinglog.Text & vbCrLf 

End If 

txtpinglog.Text = txtpinglog.Text & pingresult 

For i = 0 To 31 

pbrtime(i).Value = pbrtime(i + 1).Value 

Next 

pbrtime(32).Value = 0 







'loging 

If chklog.Value = 1 Then 

If errorflag = False Then 

errorflag = True 

Open "c:\pinglog.txt" For Append As #2 

Print #2, Now 

Print #2, pingresult 

Print #2, String(91, "*") 

Close #2 

End If 

End If 

lcount = 0 

mindelay = 0 

maxdelay = 0 

avgdelay = 0 

totaldelay = 0 



lblmin = mindelay 

lblmax = maxdelay 

lblavg = avgdelay 



Else 

lcount = lcount + 1 

Ptime = CInt(Mid(txtoutput.Text, InStr(1, txtoutput.Text, "time") + 5, InStr(1, txtoutput.Text, "ms ") - InStr(1, txtoutput.Text, "time") - 5)) 

pbyte = CInt(Mid(txtoutput.Text, InStr(1, txtoutput.Text, "bytes=") + 6, InStr(1, txtoutput.Text, " time") - InStr(1, txtoutput.Text, "bytes=") - 6)) 

pttl = CInt(Mid(pingresult, InStr(1, pingresult, "TTL=") + 4, Len(pingresult) - InStr(1, pingresult, "TTL=") - 5)) 



tmin = CInt(Mid(txtoutput.Text, InStr(1, txtoutput.Text, "Minimum = ") + 10, InStr(InStr(1, txtoutput.Text, "Minimum = "), txtoutput.Text, "ms,") - InStr(1, txtoutput.Text, "Minimum = ") - 10)) 

tmax = CInt(Mid(txtoutput.Text, InStr(1, txtoutput.Text, "Maximum = ") + 10, InStr(InStr(1, txtoutput.Text, "Maximum = "), txtoutput.Text, "ms,") - InStr(1, txtoutput.Text, "Maximum = ") - 10)) 

tavg = CInt(Mid(txtoutput.Text, InStr(1, txtoutput.Text, "Average = ") + 10, InStr(InStr(1, txtoutput.Text, "Average = "), txtoutput.Text, "ms") - InStr(1, txtoutput.Text, "Average = ") - 10)) 



If mindelay = 0 Then mindelay = tmin 



If tmin < mindelay Then 

mindelay = tmin 

End If 

If tmax > maxdelay Then 

maxdelay = tmax 

End If 

totaldelay = totaldelay + tavg 

avgdelay = CInt(totaldelay / lcount) 



lblmin = mindelay 

lblmax = maxdelay 

lblavg = avgdelay 



If avgdelay > 0 Then 

For Each ctrl In frmmain 

If TypeOf ctrl Is ProgressBar Then 

ctrl.Max = avgdelay * 10 

End If 

Next 

End If 







pingresult = "Reply from " & txtIP.Text & ": bytes=" & pbyte & " time=" & Ptime & "ms TTL=" & pttl 

txtpinglog.Text = "" 

For i = 0 To 22 

pingMessage(i) = pingMessage(i + 1) 

If pingMessage(i + 1) <> "" Then 

If txtpinglog.Text <> "" Then 

txtpinglog.Text = txtpinglog.Text & vbCrLf 

End If 

txtpinglog.Text = txtpinglog.Text & pingMessage(i + 1) 

End If 

Next 

pingMessage(23) = pingresult 

If txtpinglog.Text <> "" Then 

txtpinglog.Text = txtpinglog.Text & vbCrLf 

End If 

txtpinglog.Text = txtpinglog.Text & pingresult 







'loging 

If chklog.Value = 1 Then 

If errorflag = True Then 

errorflag = False 

Open "c:\pinglog.txt" For Append As #2 

Print #2, Now 

Print #2, "Reconnected with " & txtIP.Text 

Print #2, String(91, "*") 

Close #2 

End If 

End If 





On Error Resume Next 

Ptime = CInt(Mid(txtoutput.Text, InStr(1, txtoutput.Text, "time=") + 5, InStr(1, txtoutput.Text, "ms ") - InStr(1, txtoutput.Text, "time=") - 5)) 

For i = 0 To 31 

pbrtime(i).Value = pbrtime(i + 1).Value 

Next 

pbrtime(32).Value = Ptime 



End If 

Close #1 

End If 

Else 

frmmain.MousePointer = 0 

VarX = MsgBox("You have not entered an ip address or the number of times you want to ping.", vbCritical, "Error has occured") 

End If 

Wend 

End Sub 

Private Sub Command1_Click() 

Load frmAbout 

frmAbout.Show 1 

End Sub 

Private Sub Form_Load() 

errorflag = False 

totaldelay = 0 

mindelay = 0 

maxdelay = 0 

avgdelay = 0 

lcount = 0 



Open "C:\log.txt" For Output As #1 

Close #1 

End Sub 

Private Sub SelectText(ByRef textObj As RichTextBox) 

textObj.SelStart = 0 

textObj.SelLength = Len(textObj) 

End Sub 

Private Sub Label6_Click() 

End Sub 

Private Sub Form_Unload(Cancel As Integer) 

End 

End Sub 

Private Sub Label2_Click() 

End Sub 

Private Sub Slider1_Change() 

Select Case Slider1.Value 

Case 0: txtbuffer.Text = 1000 

Case 1: txtbuffer.Text = 2000 

Case 2: txtbuffer.Text = 3000 

Case 3: txtbuffer.Text = 4000 

End Select 



lcount = 0 

mindelay = 0 

maxdelay = 0 

avgdelay = 0 

totaldelay = 0 



lblmin = mindelay 

lblmax = maxdelay 

lblavg = avgdelay 



End Sub 

Private Sub Timer1_Timer() 



End Sub 

Private Sub txtIP_GotFocus() 

Call SelectText(txtIP) 

End Sub 



Private Sub txtOutput_GotFocus() 

' Call SelectText(txtoutput) 

End Sub 

Private Sub txtStatus_Click() 

txtIP.SetFocus 

End Sub