'Alan Kaplan at va dot gov 11/30/2009
'All the interesting bits were written by Torgeir Bakken
'from code at http://www.ureader.com/message/1436360.asp
'I added command line support, output to msgbox, and time conversion
Option Explicit
Dim strComputer
Dim message
If WScript.Arguments.Count = 1 Then
strComputer = WScript.Arguments(0)
Else
strComputer = InputBox("Check for logged on users of what PC","PC Name")
End If
If strcomputer = "" Then WScript.Quit
strComputer = UCase(strComputer)
LoggedOnUser()
'================ Functions and Subs ==============
Sub LoggedOnUser()
On Error Resume Next
Dim objWMI
Dim colSessions, colList, objItem
Dim objSession
Dim strLType
Set objWMI = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2")
If Err <> 0 Then
MsgBox "Failed. " & Err.Description,vbCritical + vbOKOnly,"Error"
WScript.Quit
End If
Set colSessions = objWMI.ExecQuery _
("Select * from Win32_LogonSession Where LogonType = 2 OR LogonType = 10")
If colSessions.Count = 0 Then
message = "No interactive users found"
Else
Message = "Found:"
For Each objSession in colSessions
If objSession.LogonType = 2 Then
strLtype = "Console"
Else
strLtype= "RDP/Terminal Server"
End If
Set colList = objWMI.ExecQuery("Associators of " _
& "{Win32_LogonSession.LogonId=" & objSession.LogonId & "} " _
& "Where AssocClass=Win32_LoggedOnUser Role=Dependent" )
For Each objItem in colList
message = message & vbNewLine & _
"User: " & objItem.Domain & "\" & objItem.Name & vbNewLine & _
"Full Name: " & objItem.FullName & vbNewLine & _
"Logon type: " & strLType & vbNewLine
Next
message = message & "Session start time: " & LocalTime(objSession.StartTime) & vbNewLine
Next
End If
'MsgBox message,vbOKOnly,strComputer
IEMessage message,"Users On " & strComputer,"lt Blue",600,600,True
End Sub
Function LocalTime(dtmInstallDate)
LocalTime = CDate(Mid(dtmInstallDate, 5, 2) & "/" & _
Mid(dtmInstallDate, 7, 2) & "/" & Left(dtmInstallDate, 4) _
& " " & Mid (dtmInstallDate, 9, 2) & ":" & _
Mid(dtmInstallDate, 11, 2) & ":" & Mid(dtmInstallDate, _
13, 2))
End Function
Sub IEMessage(message,strTitle,strBGColor,iHeight,IWidth,bPrint)
Dim oIE, oPage
Dim strComputer, strBorder, strFont
Dim strFormatOn, strFormatOff, iTSView
Set oIE = CreateObject("InternetExplorer.Application")
iTSview = 0 '1 for troubleshooting, allows view source menu
strBorder = 1 'Best appearance is strBorder 1
strFont = "Arial"
oIE.Navigate "about:blank"
oIE.AddressBar = False
oIE.Height = iHeight
oIE.Width = IWidth
oIE.MenuBar = iTSView
oIE.ToolBar = iTSView
oIE.StatusBar = False
oIE.Left = 50
oIE.Top = 50
oIE.Visible = 1
message = Replace(message,vbcrlf,"
"& vbcrlf)
Do While (oIE.Busy)
Wscript.Sleep 250
Loop
Set oPage = oIE.Document
oPage.Open
oPage.Writeln "" & strTitle & ""
oPage.Writeln ""
oPage.Writeln ""
oPage.Writeln "" & strTitle & "
"
oPage.Writeln "" & Message & "
"
If bPrint Then
oPage.WriteLn ""
End If
oPage.Writeln ""
oPage.Write()
oPage.Close
End Sub