http://dieseyer.de • all rights reserved • © 2011 v11.4

</html>
<head>

<!--

'*** v9.B *** www.dieseyer.de ******************************
'
' Datei: pclistetesten.hta
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'***********************************************************

SHOWINTASKBAR="no"
WINDOWSTATE="maximize"
BORDER="none"
INNERBORDER="no"
SCROLL="No"
NAVIGABLE="no"
ICON="dieseyer.ico"

-->
<HTA:APPLICATION ID="oHTA"
APPLICATIONNAME="PC Liste testen"
SINGLEINSTANCE="yes"
MAXIMIZEBUTTON="no"
>

<title>PC Liste testen</title>

<style type="text/css">

html, body { background-color: #116; color: #ec0; font-weight: normal; font-size: 9pt; font-family: verdana, arial, sans-serif }

</style>

</head>


<script language="VBscript">

Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl

Dim arrTst, arrZeilen(), Titel, HtaSelbst, HtaDatum
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim AktVerz : AktVerz = fso.GetParentFolderName( HtaSelbst ) ' : MsgBox "AktVerz: " & AktVerz, , "046 :: "

'***********************************************************
Function BeimLaden() ' ruft einige Routinen auf
'***********************************************************
On Error Resume Next
window.moveto 0, 0
On Error Goto 0
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Tst

Titel = oHTA.APPLICATIONNAME

HtaSelbst = oHTA.CommandLine


' Auf Vorhandensein der Datei mit IP-Adr. in Array einlesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = AktVerz & "pclistetesten.ini"
If not fso.FileExists( Tst ) Then
MsgBox "Datei mit IP-Adr. fehlt:" & vbCRLF & vbCRLF & Tst, vbCritical, "066 :: " & Titel
Exit Function
End If


' Datei mit IP-Adr. in Array einlesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrTst = DateiInhalt( Tst )

Tst = "075 :: UBound( arrTst ) = " & UBound( arrTst )
' MsgBox Tst, , "076 :: " ' Anzahl der Zeilen anzeigen


ReDim Preserve arrZeilen( UBound( arrTst ) )
Tst = "080 :: UBound( arrZeilen ) = " & UBound( arrZeilen )
' MsgBox Tst, , "081 :: " ' Anzahl der Zeilen anzeigen


' ArrayZeigen( arrTst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


' Array mit IP-Adr. schnell sortieren - ein 'Quicky'
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
QuickSort arrTst, LBound( arrTst ), UBound( arrTst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


' ArrayZeigen( arrTst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


' call pclistetesten( 0 )

window.setTimeout "pclistetesten('0')", 3* 333
window.setTimeout "ErgebnZeigen()", 333
' window.setInterval "ErgebnZeigen()", 333

End Function ' BeimLaden()

'***********************************************************
Sub ErgebnZeigen()
'***********************************************************
Dim t, i

t = t & "<table border=""1"" >"
' t = t & "<table border=""1"" width=""100%"">"
t = t & " <colgroup>"
t = t & " <col width=""150"">"
t = t & " <col width=""200"">"
t = t & " <col width=""300"">"
t = t & " <col width=""400"">"
t = t & " <col >"
t = t & " </colgroup>"
For i = LBound( arrTst ) to UBound( arrTst )
t = t & " <tr>"
t = t & " <td><span id=Zeile" & i & "> " & i & " </span></td>"
t = t & " <td>" & arrTst( i ) & "</td>"
t = t & " <td>" & arrTst( i ) & "</td>"
t = t & " <td>" & arrTst( i ) & "</td>"
t = t & " </tr>"
Next
t = t & "</table>"
t = t & "<br>"
' t = t & "<center>"
' t = t & " " & now() & " - " & Timer()
' t = t & " <br>"
' t = t & " <br>"
' t = t & " Neu starten mit [F5]"
' t = t & " <br>"
' t = t & " <br>"
' t = t & "</center>"

t = t & "<center style="" font-size:7Pt; "">"
' t = t & "<a href=""http://dieseyer.de/scr/pclistetesten.hta"" ><b>pclistetesten.hta</b></a>"
t = t & "<a href=""http://dieseyer.de"" ><b><b>www.dieseyer.de</b></b></a>"
t = t & "<a href=""http://dieseyer.de/dse-impressum.html"" > • © 2009 by dieseyer • all rights reserved • </a>"
t = t & "<a href=""http://dieseyer.de"" ><b><b>www.dieseyer.de</b></b></a>"
t = t & "</center>"

On Error Resume Next
document.all.Anzeige.innerHTML = t
On Error Goto 0
End Sub ' ErgebnZeigen()

'***********************************************************
Sub pclistetesten( Nr )
'***********************************************************
' MsgBox "Nr.: '" & Nr & "'" & vbCRLF & arrTst( Nr )
Dim t
If WMIpingOK( arrTst( Nr ) ) Then
t = "<span style=""color:green; font-weight:bold; "">  OK  " & Time() & "</span>"
' MsgBox "document.all.Zeile" & Nr & ".innerHTML = " & t
' window.setTimeout "document.all.Zeile" & Nr & ".innerHTML = 'xxx'", 3*333
Else
t = "<span style=""color:fuchsia; font-weight:bold; ""> <strike> OK </strike> " & Time() & "</span>"
' MsgBox "document.all.Zeile" & Nr & ".innerHTML = " & t
' window.setTimeout "document.all.Zeile" & Nr & ".innerHTML = " & t, 3333
' window.setTimeout "document.all.Zeile" & Nr & ".innerHTML = 'xxx'", 3*333
End If

window.setTimeout "document.all.Zeile" & Nr & ".innerHTML = '" & t & "'", 1*333

Nr = Nr + 1 : If Nr > UBound( arrTst ) Then Nr = LBound( arrTst )

window.setTimeout "pclistetesten('" & Nr & "')", 3 * 333

End Sub ' pclistetesten( Nr )

'*** v9.3 *** www.dieseyer.de ******************************
Function WMIpingOK( PCName )
'***********************************************************
' Aufruf z.B.: If not WMIpingOK( ZielPC ) Then MsgBox ZielPC & " ist nicht erreichbar." : WScript.Quit
Dim Tst, objPing, objStatus
On Error Resume Next
err.Clear
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address = '" & PCName & "'")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : WMIpingOK = "Fehler: " & Tst : Exit Function

WMIpingOK = True
For Each objStatus in objPing
If IsNull(objStatus.StatusCode) or objStatus.StatusCode<>0 Then
' WScript.Echo("PCName " & PCName & " is not reachable")
WMIpingOK = False
End If
Next
Set objPing = Nothing
End Function ' WMIpingOK( PCName )

'*** v8.3 *** www.dieseyer.de *******************************
Function QuickSort( vntArray, intVon, intBis )
'************************************************************

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' http://www.heise.de/ct/ftp/listings.shtml
' Der gute, alte QuickSort-Algorithmus als Windows-Script. c't 5/2002
' Copyright Ralf Nebelo/c't

' QuickSort arrTest, LBound(arrTest), UBound(arrTest) ' Array "arrTest" wird sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Dim i, j
Dim vntTestWert, intMitte, vntTemp

If intVon < intBis Then
intMitte = (intVon + intBis) \ 2
vntTestWert = vntArray(intMitte)
i = intVon
j = intBis

Do
Do While UCase( vntArray(i) ) < Ucase( vntTestWert )
' Do While vntArray(i) < vntTestWert
i = i + 1
Loop

Do While UCase( vntArray(j) ) > Ucase( vntTestWert )
' Do While vntArray(j) > vntTestWert
j = j - 1
Loop

If i <= j Then
vntTemp = vntArray(j)
vntArray(j) = vntArray(i)
vntArray(i) = vntTemp
i = i + 1
j = j - 1
End If
Loop Until i > j

If j <= intMitte Then
Call QuickSort(vntArray, intVon, j)
Call QuickSort(vntArray, i, intBis)
Else
Call QuickSort(vntArray, i, intBis)
Call QuickSort(vntArray, intVon, j)
End If
End If

End Function ' QuickSort( vntArray, intVon, intBis )


'*** v10.5 *** www.dieseyer.de ****************************
Function DateiInhalt( DateiX )
'*********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim FileIn : Set FileIn = fso.OpenTextFile( DateiX, 1 )
Dim Txt, Tst, i

i = 0 : ReDim Preserve Zeile(i) : Zeile(i) = ""

Do While Not ( FileIn.atEndOfStream )
' Tst = Trim( FileIn.Readline )
Tst = FileIn.Readline
' If Len( Tst ) > 2 Then
Txt = Txt & Tst & vbCRLF
ReDim Preserve Zeile(i)
Zeile(i) = Tst
i = i + 1
' End If
Loop
' MsgBox Txt, , "11 :: "

If UBound( Zeile ) < 1 AND Zeile( UBound( Zeile ) ) = "" Then Zeile( UBound( Zeile ) ) = "LEER"

FileIn.Close
Set FileIn = nothing
DateiInhalt = Zeile
End Function ' DateiInhalt( DateiX )


'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.

Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf

For i = LBound( InArray ) to UBound( InArray )

n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If

n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For

Next

Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF

Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )

TxtOben = Kopf & TxtOben & Tst & TxtUnten

' LogEintrag "303 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "304 :: " & Titel

End Function ' ArrayZeigen( InArray )

'**************************************************************
Sub document_onKeyDown
'**************************************************************
' TastTaste = window.event.keyCode
' Trace32Log "312 :: Betätigte Taste: '" & TastTaste & "'", 1
' If TastTaste = 13 Then Call neuesEnde()
End Sub


</script>

<body onLoad="BeimLaden()">

<span id="Anzeige"></span><br>
<!--
<span id="InfoTxt" style="text-align: center; width: 642px; height: 3em; position: absolute; top: 478px; left: 11px; border: 2px solid red; background-color: #00d;"></span>
-->

</body>
</html>

http://dieseyer.de • all rights reserved • © 2011 v11.4