'Alan Kaplan at va dot gov 11/30/2009
'This script gets the email address of terminal server 
'users and puts them into your clipboard to notify them of downtime.
'Freqently the Messenger service is turn off, which makes 
'sending a message to the logged on users of a terminal server more difficult.  
'Also, good security practices mean your admin account is not mail enabled. 
'This allows you to get the names, and to paste them into an email.

Option Explicit
Dim strComputer
Dim message, retval

Const ADS_SCOPE_SUBTREE = 2
dim objConnection, objCommand
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = ("ADsDSOObject")
objConnection.Open "Active Directory Provider"
objCommand.ActiveConnection = objConnection
Dim aUsers: aUsers=Array()
Dim i, root, sADSPath
'Default for separating addresses.  Works with Exchange
Dim strMailDelimiter : strMailDelimiter = ";"


message = "This script gets the email address of terminal server " & _
"users and puts them into your clipboard to notify them of downtime." & vbNewLine & vbNewLine & _
"Get email addresses for logged on users of what server"

If WScript.Arguments.Count = 1 Then
	strComputer = WScript.Arguments(0)
Else
	Dim WshShell
	Set wshShell = WScript.CreateObject("WScript.Shell")
	strComputer = wshShell.ExpandEnvironmentStrings("%COMPUTERNAME%")
	strComputer = InputBox(message,"Server Name",strComputer)
End If 

If strcomputer = "" Then WScript.Quit
strComputer = UCase(strComputer)

'Get the default ADsPath for the domain to search. 
Set root = GetObject("LDAP://rootDSE")
sADSPath = root.Get("defaultNamingContext")

'Note you can comment this out if local domain is always correct
sADSPath = InputBox("Start search for user's at what AD path?","Path",sADSPath)

LoggedOnUser()

message = ""
For i = 0 To UBound (aUsers)
	message = message & MailAddress(aUsers(i)) & strMailDelimiter
Next

retval = MsgBox ("These are the email addresses of the users on " & strComputer &_
":" & vbNewLine & vbNewLine & message & vbNewLine & vbNewLine & _
"Send to the clipboard via IE?",vbYesNo,"Add to Clipboard?")

If retval = vbYes Then	'Use IE for clipboard
	Dim objIE
	Set objIE = CreateObject("InternetExplorer.Application")
	objIE.Navigate("about:blank")
	Do Until objIE.ReadyState=4: WScript.Sleep 1: Loop
	objIE.Document.ParentWindow.ClipboardData.SetData "Text", message
	objIE.Quit
End If 


'================ Functions and Subs ==============

Sub LoggedOnUser()
	'All the interesting parts of this sub were written by Torgeir Bakken
	'from code at http://www.ureader.com/message/1436360.asp
	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 = 10")
	
	If colSessions.Count = 0 Then
	   message = "No RDP users found logged onto " & strComputer
	   MsgBox message,vbInformation,"Nothing to do!"
	   WScript.Quit
	Else
		For Each objSession in colSessions			
			Set colList = objWMI.ExecQuery("Associators of " _
			    & "{Win32_LogonSession.LogonId=" & objSession.LogonId & "} " _
			    & "Where AssocClass=Win32_LoggedOnUser Role=Dependent" )
			For Each objItem in colList
				'We do this to make sure the list is unique
			 	AddToArray aUsers,objItem.Name
			Next
		Next
	End If
End Sub 

Function MailAddress(strSAMAccount)
	Dim oRS
	'Asking the Global Catalog...
	objCommand.CommandText = "SELECT mail FROM " & _
	    "'GC://" & sADSPath & "' WHERE samAccountName = '" & strSamAccount &"'"
	objCommand.Properties("SearchScope") = ADS_SCOPE_SUBTREE
	Set oRS = objCommand.Execute
	If oRS.RecordCount = 0 Then
	    MailAddress=strSAMAccount
	Else
	    MailAddress = oRS("mail").value
	End If
End Function

Sub AddToArray(aList, NewItem)
	Dim I, ItemFound
	For I = LBound(aList) to UBound(aList)
	   If aList(I) = NewItem Then
	      ItemFound = True
	      Exit For
	   End If
	Next
	
	If Not ItemFound Then
	   ReDim Preserve aList(Ubound(aList) + 1)
	   alist(I)=newitem
	End If
End Sub