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