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

'*** v9.8 *** www.dieseyer.de ******************************
'
' Datei: AlleProzesseUndTasks.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'***********************************************************

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

Dim AlleTxt, AlleArray, AlleDict

AlleTxt = AlleProzesseUndTasksText( "." )

' Ausgabe in Popup
CreateObject("WScript.Shell").PopUp "AlleProzesseUndTasksText" & vbCRLF & vbCRLF & AlleTxt, 7, "016 :: " & WScript.ScriptName
' Ausgabe in Datei; mit Datei öffnen

CreateObject("Scripting.FileSystemObject").OpenTextFile( WSCript.ScriptFullName & ".txt" , 2, true ).Write( AlleTxt )
CreateObject("WScript.Shell").Run """" & WSCript.ScriptFullName & ".txt" & """"

AlleArray = AlleProzesseUndTasksArray( "." )

WScript.Quit

'*** v9.B *** www.dieseyer.de ******************************
Function AlleProzesseUndTasksText( PC )
'***********************************************************
' WinTuC: TasksBewerten.hta UND TasksPrüfen.vbs
' Displaying the Services Running in All Processes
' http://www.microsoft.com/technet/scriptcenter/guide/sas_ser_arwi.mspx

' Außerhalb der Prozedur müssen folgende zwei Variablen definiert werden:'
' Variablen für "Function AlleProzesseUndTasksText( PC )"
' (aus ..\WinTuC_Zauberei\TasksBewerten.hta)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ReDim Preserve arrTasks( 4, 0 ) ' wird gefüllt von: Function AlleProzesseUndTasksText( PC )
' Dim dicTasks ' wird gefüllt von: Function AlleProzesseUndTasksText( PC )
' Set dicTasks = CreateObject("Scripting.Dictionary") ' enthält die Zahl, zum Zugriff auf ein arrTask() Element

' arrTasks( 0, m ) = ' "JA" Task muss laufen - sonst Fehlermeldung
' "NE" Task muss ruhen - sonst Fehlermeldung
' "NO" für nicht festgelegt - NIE Fehlermeldung
' arrTasks( 1, m ) = colProcessIDs(i) ' ist 0, wenn der Prozess NICHT läuft
' arrTasks( 2, m ) = Tst ' Tst enthält Befehlszeile des Prozess-Aufrufs;
' arrTasks( 3, m ) = objService.DisplayName
' arrTasks( 4, m ) = objService.Description

Dim Txt, Tst, i, m
Dim objIdDictionary : Set objIdDictionary = CreateObject("Scripting.Dictionary")
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Dim colServices : Set colServices = objWMIService.ExecQuery ("Select * from Win32_Service")
Dim objService
For Each objService in colServices
If objIdDictionary.Exists(objService.ProcessID) Then
Else
objIdDictionary.Add objService.ProcessID, objService.ProcessID
End If
Next
Dim colProcessIDs
colProcessIDs = objIdDictionary.Items
m = 0
For i = 0 to objIdDictionary.Count - 1
Set colServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE ProcessID = '" & colProcessIDs(i) & "'")

For Each objService in colServices
On Error Resume Next
WScript.Sleep 33 ' ! Wird nur in VBS unterstützt; nicht in HTA!
' Durch das Sleep 33 wird die CPU-Last verringert;
' die Prozedur benötigt dadurch 3x so lange.
On Error Goto 0

' \svchost.exe wird manchmal nur als \svchost ausgegeben - das wird hier korrigiert
Tst = LCase( objService.PathName )
If InStr( Tst, ".exe" ) = 0 And InStr( Tst, "\svchost" ) > 1 Then Tst = Replace( Tst, "\svchost", "\svchost.exe" ) ' : MsgBox Tst, , "0875 :: " & Titel
Txt = Txt & vbCRLF & colProcessIDs(i) & " _" & m & "_ " & Tst & ": " & objService.DisplayName & "0875 ::: " & objService.Description

If dicTasks.Exists( objService.DisplayName ) Then
' if m < 3 OR m > 95 Then MsgBox "Gibts schon: " & objService.DisplayName & " " & dicTasks.Item( objService.DisplayName ), , "0879 :: " & Titel & "'Win32_Service'"
Else

dicTasks.Add objService.DisplayName, m
ReDim Preserve arrTasks( 4, m )

arrTasks( 0, m ) = "NO"
arrTasks( 1, m ) = colProcessIDs(i) ' ist 0, wenn der Prozess NICHT läuft
arrTasks( 2, m ) = Tst ' Tst enthält Befehlszeile des Prozess-Aufrufs;
arrTasks( 3, m ) = objService.DisplayName
arrTasks( 4, m ) = objService.Description
arrTasks( 4, m ) = "ID " & colProcessIDs(i) & " (" & objService.ProcessId & "): " & objService.Description & " (Win32_Service)"
' if m < 3 OR m > 95 Then MsgBox "Neu angelegt: >" & arrTasks( 3, m ) & "<" & vbCRLF & "ist Nr. " & dicTasks.Item( arrTasks( 3, m ) ), , "0891 :: " & Titel
m = m + 1
End If

' bisher war immer: objService.Caption = objService.DisplayName
' If not objService.Caption = objService.DisplayName Then MsgBox objService.Caption & vbCRLF & objService.DisplayName, , "0896 :: " & Titel
Next
Next

Dim colItems : Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", &h10 + &h20 )
Dim objItem
For Each objItem In colItems
Tst = Trim( objItem.CommandLine )
If isNull( Tst ) Then Tst = objItem.Name ' : MsgBox "'" & Tst & "'" & vbCRLF & "Name: >" & objItem.Name & ">" & vbCRLF & "CommandLine: >" & objItem.CommandLine & "<" & vbCRLF & "Description: >" & objItem.Description & "<" & vbCRLF & "ProcessID: >" & objItem.ProcessID & "<", , "0904 :: " & Titel
' MsgBox "'" & Tst & "'" & vbCRLF & "Name: >" & objItem.Name & ">" & vbCRLF & "CommandLine: >" & objItem.CommandLine & "<" & vbCRLF & "Description: >" & objItem.Description & "<" & vbCRLF & "ProcessID: >" & objItem.ProcessID & "<", , "0905 :: " & Titel

' einige Prozesse werden in Win32_Process und Win32_Service aufgeführt
If objIdDictionary.Exists( objItem.ProcessID ) Then
' If objIdDictionary.Exists( objItem.ProcessID ) OR objItem.ProcessID = 0 Then
Else
' On Error Resume Next
objIdDictionary.Add objItem.ProcessID, objItem.ProcessID
If err.Number > 0 Then Tst = Tst & " .. " & objItem.ProcessID
On Error Goto 0
If dicTasks.Exists( Tst ) Then Tst = Tst & " ,, " & m
If dicTasks.Exists( Tst ) Then
MsgBox "FEHLER: Gibts schon: '" & Tst & "' - Nr.: " & dicTasks.Item( Tst ) & " (" & m & ")" & vbCRLF & "Name: >" & objItem.Name & ">" & vbCRLF & "CommandLine: >" & objItem.CommandLine & "<" & vbCRLF & "Description: >" & objItem.Description & "<" & vbCRLF & "ProcessID: >" & objItem.ProcessID & "<", , "0917 :: " & Titel
Else
' dicTasks.Add objItem.Name & " (" & objItem.ProcessId & ")", m
dicTasks.Add Trim( Tst ), m
ReDim Preserve arrTasks( 4, m )

arrTasks( 0, m ) = "NO"
arrTasks( 1, m ) = objItem.ProcessId ' ist 0, wenn der Prozess NICHT läuft
arrTasks( 2, m ) = Tst
arrTasks( 2, m ) = "" ' bei den Prozessen ist nicht der Prozessname sondern die CommandLine das entscheidende
arrTasks( 3, m ) = objItem.Name
arrTasks( 3, m ) = Tst ' bei den Prozessen ist nicht der Prozessname sondern die CommandLine das entscheidende
arrTasks( 4, m ) = objItem.Description
arrTasks( 4, m ) = "ID " & objItem.ProcessId & " (" & objItem.ParentProcessId & "): " & objItem.Description & " (Win32_Process)"
' if m < 3 OR m > 95 Then MsgBox "Neu angelegt: >" & arrTasks( 3, m ) & "<" & vbCRLF & "ist Nr. " & dicTasks.Item( arrTasks( 3, m ) ), , "0931 :: " & Titel & "'Win32_Process'"
m = m + 1
End If
End If
Next

Set colItems = nothing
Set colServices = nothing
Set objWMIService = nothing
Set objIdDictionary = nothing

On Error Resume Next ' sonst Fehler in TasksPrüfen.vbs

Txt = "0944 :: Taskliste ist erstellt. (" & Now() & ")" ' & Replace( Txt, vbCRLF, "<br>" )
window.setTimeout "InfoZeigen('" & Txt & "')" , 33

' window.setTimeout "ArrayZeigenZweiDimensionen( arrTasks )" , 333

Txt = "0949 :: Anzeige wird ""zusammen gebaut"" . . . (" & Now() & ")"
window.setTimeout "InfoZeigen('" & Txt & "')" , 66

window.setTimeout "TasksListeKonfigurationZeigen" , 99

End Function ' AlleProzesseUndTasksText( PC )


'*** v9.8 *** www.dieseyer.de ******************************
Function AlleProzesseUndTasksArray( PC )
'***********************************************************
' Displaying the Services Running in All Processes
' http://www.microsoft.com/technet/scriptcenter/guide/sas_ser_arwi.mspx

Dim Txt, Tst, i
Dim objIdDictionary : Set objIdDictionary = CreateObject("Scripting.Dictionary")
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
' Dim colServices : Set colServices = objWMIService.ExecQuery ("Select * from Win32_Service Where State <> 'Stopped'")
Dim colServices : Set colServices = objWMIService.ExecQuery ("Select * from Win32_Service")
Dim objService
For Each objService in colServices
If objIdDictionary.Exists(objService.ProcessID) Then
Else
objIdDictionary.Add objService.ProcessID, objService.ProcessID
End If
Next

Dim colProcessIDs
colProcessIDs = objIdDictionary.Items

For i = 0 to objIdDictionary.Count - 1
Set colServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE ProcessID = '" & colProcessIDs(i) & "'")
For Each objService in colServices

' \svchost.exe wird manchmal nur als \svchost ausgegeben - das wird hier korrigiert
Tst = LCase( objService.PathName )
If InStr( Tst, ".exe" ) = 0 And InStr( Tst, "\svchost" ) > 1 Then Tst = Replace( Tst, "\svchost", "\svchost.exe" ) ' : MsgBox Tst, , "096 :: "

Txt = Txt & vbCRLF & colProcessIDs(i) & " _ " & Tst & ": " & objService.DisplayName & " " & objService.Description

' bisher war immer: objService.Caption = objService.DisplayName
' If not objService.Caption = objService.DisplayName Then MsgBox objService.Caption & vbCRLF & objService.DisplayName, , "101 :: "

Next
Next

AlleProzesseUndTasksArray = Txt

End Function ' AlleProzesseUndTasksArray( PC )


'*** 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 )


'*** 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 "210 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "211 :: " & WScript.ScriptName

End Function ' ArrayZeigen( InArray )

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