pinger
HTA appka na pingani kompu
Ostatní
<!DOCTYPE html >
<html>
<head>
<title>Progress Bar Sample</title>
<HTA:APPLICATION APPLICATIONNAME="PingApp"
CAPTION="yes" ID="oPingApp" MAXIMIZEBUTTON="no"
SCROLL="no" VERSION="1.0"
SINGLEINSTANCE="yes"
/>
</head>
<!-- ProgressBar code -->
<script language="VBScript">
'Stop
Dim CProgressBar_Instances
CProgressBar_Instances = 0
Class CProgressBar
Private intProgress
Private intMax
Private strElementId
Public Sub Create(objDocument, objParentElement)
Dim strHtml, i
CProgressBar_Instances = CProgressBar_Instances + 1
strElementId = "elProgressBar" & CProgressBar_Instances
strHtml = "<div id="""& strElementId &"Counter"" style=""float: left"">0/0</div>" & vbCrLf
strHtml = strHtml & "<table style=""margin-left:10px; margin-right: 10px; border:thin solid #cccccc; float: left"" id=""" & strElementId & """>" & vbCrLf & _
" <tr>" & vbCrLf
For i = 1 to 10
strHtml = strHtml & " <td bgcolor=""white""> </td>" & vbCrLf
Next
strHtml = strHtml & " </tr>" & vbCrLf & _
"</table>" & vbCrLf & _
"<div id="""& strElementId &"Percent"">0%</div>" & vbCrLf
objParentElement.innerHtml = objParentElement.innerHtml & strHtml
End Sub
Public Sub Reset (intMaxCount)
intProgress = 0
intMax = intMaxCount
Redraw
End Sub
Public Sub SetProgress (intDone)
intProgress = intDone
Redraw
End Sub
Private Sub Redraw
Dim objCol, i, objPgBarElement, intDisplayBars, intPercent
Set objPgBarElement = Document.getElementById(strElementId)
Set objCol = objPgBarElement.getElementsByTagName("td")
intDisplayBars = Int(intProgress/(intMax/10))
intPercent = Int(intProgress/(intMax/100))
'elMessages.innerText = elMessages.innerText & intProgress & vbCrLf
For i = 0 to 9
if i < intDisplayBars then
objCol(i).bgcolor = "blue"
else
objCol(i).bgcolor = "white"
end if
next
Set objCounter = Document.getElementById(strElementId & "Counter")
objCounter.innerHtml = "" & intProgress & "/" & intMax
Set objPercentage = Document.getElementById(strElementId & "Percent")
objPercentage.innerHtml = "" & intPercent & "%"
End Sub
End Class
</script>
<script language="VBScript">
Dim aComputers(), objProgressBar, intHotovo
Dim objFSO, objShell, strPingVbs, objPingProc, strPingFile, strAutomatonStatus, strAddress
Dim strTempDir
Dim symStart, symPause, symStop, symClose
Function LoadHostnames()
Dim strFile, objStream, intCount, strHostname
'aComputers = Array("DESKTOP-UUUIMN1", "DESKTOP-UUUIMN2", "DESKTOP-UUUIMN1", "DESKTOP-UUUIMN3", "DESKTOP-UUUIMN1", "DESKTOP-UUUIMN6", "DESKTOP-UUUIMN1", "DESKTOP-UUUIMN6", "DESKTOP-UUUIMN1")
strFile = Dlg.OpenFileDlg(CStr(Replace(oPingApp.commandLine, Chr(34), "")), , CStr("txt files (.txt)|.txt"), CStr("Otvor vstup..."))
If strFile = "" Then
MsgBox "Subor nevybrany !!!", vbCritical
LoadHostnames = False
Else
Set objStream = objFSO.OpenTextFile(strFile, 1)
intCount = 0
Do Until objStream.AtEndOfStream
strHostname = UCase(Trim(objStream.Readline))
If strHostname <> "" Then
ReDim Preserve aComputers(intCount)
aComputers(intCount) = strHostname
intCount = intCount + 1
End If
Loop
objStream.Close
Set objStream = Nothing
LoadHostnames = True
End If
End Function
Function WritePingVbs()
Dim strScriptPath, objStream, strScriptContents
strScriptContents = _
"Dim strCmd, objShell, strPingParams" & vbCrLf & _
"If WScript.Arguments(2) = ""1"" Then strPingParams = ""-n 2"" Else strPingParams = ""-a -n 1"" End If" & vbCrLf & _
"strCmd = ""%comspec% /c """"ping.exe "" & strPingParams & "" "" & WScript.Arguments(0) & "" > "" & WScript.Arguments(1) & """"""""" & vbCrLf & _
"Set objShell = CreateObject(""WScript.Shell"")" & vbCrLf & _
"objShell.Run strCmd , 0, True" & vbCrLf & _
"Set objShell = Nothing" & vbCrLf
strScriptPath = objFSO.BuildPath(strTempDir, "ping.vbs")
Set objStream = objFSO.OpenTextFile(strScriptPath, 2, True, 0)
strScriptContents = objStream.Write(strScriptContents)
objStream.Close
WritePingVbs = strScriptPath
End Function
Function Automaton()
On Error Resume Next
Dim strCmd, intRetVal, strParams, objPingFile, strAll, strTemp
Select Case strAutomatonStatus
Case "pause ready"
' let's start the same hostname again after unpaused
strAutomatonStatus = "ping ready"
'do not run Window.setTimeout ... just exit function
Case "stop ready"
' let's start the first hostname after started
intHotovo = 0
strAutomatonStatus = "ping ready"
'do not run Window.setTimeout ... just exit function
Case "ping ready"
' clean after pause or stop
If strPingFile <> "" And objFSO.FileExists(strPingFile) Then
objFSO.DeleteFile strPingFile
End If
strTemp = objFSO.GetTempname()
strPingFile = objFSO.BuildPath(strTempDir, strTemp)
strCmd = "wscript.exe """ & strPingVbs & """ """ & aComputers(intHotovo) & """ """ & strPingFile & """ ""1"""
Set objPingProc = objShell.Exec(strCmd)
'elMessages.innerHtml = "*" & strCmd & "*"
' first ping started ... check it after some delay
strAutomatonStatus = "first ping running"
Window.SetTimeout "Automaton", 100
Case "first ping running"
If objPingProc.Status = 1 Then
' process the first ping result
Set objPingFile = objFSO.OpenTextFile(strPingFile)
strAll = objPingFile.ReadAll
objPingFile.Close
objFSO.DeleteFile strPingFile
Set objPingFile = Nothing
If InStr(strAll, "Pinging ") Then
strAddress = Mid(strAll, InStr(strAll,"[") + 1, InStr(strAll,"]") - InStr(strAll,"[") - 1)
strCmd = "wscript.exe """ & strPingVbs & """ """ & strAddress & """ """ & strPingFile & """ ""2"""
Set objPingProc = objShell.Exec(strCmd)
' second ping started ... check it after some delay
strAutomatonStatus = "second ping running"
Window.SetTimeout "Automaton", 100
Else
elMessages.innerHtml = aComputers(intHotovo) & ": Could not be found"
intHotovo = intHotovo + 1
objProgressBar.SetProgress intHotovo
If intHotovo > UBound(aComputers) then
elMessages.innerHtml = elMessages.innerHtml & " ... all computers done!"
intHotovo = 0
strAutomatonStatus = "ping ready"
'do not run Window.setTimeout ... all computers done
Else
' second ping not needed for nonexistent computer ... let's move to next computer
strAutomatonStatus = "ping ready"
Window.SetTimeout "Automaton", 0
End If
End If
Else
' first ping is still running, check it after another delay
Window.SetTimeout "Automaton", 100
End If
Case "second ping running"
If objPingProc.Status = 1 Then
' process the second ping result
Set objPingFile = objFSO.OpenTextFile(strPingFile)
strAll = objPingFile.ReadAll
objPingFile.Close
objFSO.DeleteFile strPingFile
Set objPingFile = Nothing
If InStr(strAll, aComputers(intHotovo)) Then
' good dns record
elMessages.innerHtml = aComputers(intHotovo) & ": Good DNS record"
Else
' bad dns record
elMessages.innerHtml = aComputers(intHotovo) & ": DNS mismatch"
revIP = ""
For i = 1 To 3
revIP = revIP & Right(strAddress, Len(strAddress) - InStrRev(strAddress, ".")) & "."
strAddress = Left(strAddress, InStrRev(strAddress, ".") - 1)
Next
End If
intHotovo = intHotovo + 1
objProgressBar.SetProgress intHotovo
If intHotovo > UBound(aComputers) then
elMessages.innerHtml = elMessages.innerHtml & " ... all computers done!"
intHotovo = 0
strAutomatonStatus = "ping ready"
'do not run Window.setTimeout ... all computers done
Else
'computer is done ... go for another computer next time
strAutomatonStatus = "ping ready"
Window.SetTimeout "Automaton", 0
End If
Else
' second ping is still running, check it after another delay
Window.SetTimeout "Automaton", 100
End If
Case Else
' Houston we have something bad in our code!
MsgBox "Unexpected strAutomatonStatus: '" & strAutomatonStatus & "'! Starting debugger!"
Stop
End Select
End Function
Function StartPauseContinuePinging()
If elBtnStartPauseContinue.value = symStart Then
' paused or stopped
If elBtnStop.disabled = True Then
' stopped
If LoadHostnames() = True Then
elBtnStop.disabled = False
elBtnStartPauseContinue.value = symPause
intHotovo = 0
objProgressBar.Reset Ubound(aComputers)+1
' let's start our pinging automaton
Window.SetTimeout "Automaton", 0
End If
Else
' paused
elBtnStartPauseContinue.value = symPause
Window.SetTimeout "Automaton", 0
End If
Else
' playing
elBtnStartPauseContinue.value = symStart
strAutomatonStatus = "pause ready"
End If
End Function
Function StopPinging()
elBtnStartPauseContinue.value = symStart
elBtnStop.disabled = True
intHotovo = 0
objProgressBar.Reset Ubound(aComputers)+1
strAutomatonStatus = "pause ready"
End Function
Function Window_OnLoad()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
strTempDir = objFSO.BuildPath(objFSO.GetParentFolderName(oPingApp.document.Script.location.pathname), objFSO.GetTempName())
objFSO.CreateFolder strTempDir
Set objProgressBar = New CProgressBar
objProgressBar.Create Document, elMain
symStart = Chr(&H34&)
symPause = Chr(&H3B&)
symStop = Chr(&H3C&)
symClose = Chr(&H72&)
strPingVbs = WritePingVbs()
strAutomatonStatus = "ping ready"
strPingFile = ""
width = 705
height = 405
Self.resizeTo width, height
Self.MoveTo (Screen.Width - width) / 2, (Screen.Height - height) / 2
StartPauseContinuePinging
End Function
Sub Window_OnBeforeUnload
strAutomatonStatus = "pause ready"
' let's clean after some delay ... after all external processes are finished
objShell.Run "%comspec% /C ""(ping -n 4 127.0.0.1) & (rmdir /S /Q " & strTempDir & ")""", 0, False
End Sub
</script>
<body bgColor="white">
<OBJECT id=Dlg classid="CLSID:3050F4E1-98B5-11CF-BB82-00AA00BDCE0B" width=0 height=0></object>
<!--{{InsertControlsHere}}-Do Not remove this line-->
<table cellpadding="20">
<tr>
<td width="200">
<div id="elMain"></div>
</td>
<td>
<button id="elBtnStartPauseContinue" style="font-family:webdings; width: 40px;height:40px;font-size:large" onclick="vbscript: StartPauseContinuePinging">4</button>
<button id="elBtnStop" style="font-family:webdings; width: 40px;height:40px;font-size:large" onclick="vbscript: StopPinging" disabled="disabled"><</button>
<button id="elBtnClose" style="margin-left:20px;font-family:webdings; width: 40px;height:40px;font-size:large" onclick="vbscript: window.close">r</button>
</td>
</tr>
<tr>
<td colspan="2">
<pre id="elMessages"></pre>
</td>
</tr>
</table>
</body>
</html>Neformátovaný
Přidáno: 15.9.2018
Expirace: Neuvedeno
Autor: Jirka Jr