' NTUserInfo_IE.vbs, Alan Kaplan
' This was originally based on Get User Information NTUser.wsf, Version 1
' 11-26-2001 by Ralph Montgomery (rmonty@myself.com)

'3/23/2009  I have been using this script for a very long time, and have probably hacked
'it beyond recognition.  I take neither the credit nor the blame for the clumsy bits...
'10/23/2009 added support for and enumeration of UPN
'5/23/2010 switched from IE to Word for clipboard
'3/3/2013 IE output.  Overhauled and cleaned up code, re-arranged output and added 2FA

Option Explicit
Dim strUserName, objUserDomain, objGroup, objUser, strGroupList
Dim WshShell, strMessage, strTitle
Dim oDomain, strNTDomain, strVer
Dim  strSortedGroups, arrGroupList, strUserList
Dim bCanChangePW, objChangePwd, strProfile
Dim bPWNeverExpires, objFlags, oPwdExpire, strPwdExpires
Dim objAcctDisabled, intPwdExpired, bPwdExpired,bAccountDisabled
Dim StrQuote, iBadLogins, iMaxPadPw, iAccountLockout, iPwdAge, bSCRqd, bAdmin

Set WshShell = WScript.CreateObject("WScript.Shell")
strVer = "3.2"
strQuote = Chr(34)
Dim strNTName, strUPN
Const ADS_NAME_INITTYPE_GC = 3
Const ADS_NAME_TYPE_NT4 = 3
Const ADS_NAME_TYPE_1779 = 1
Const ADS_NAME_TYPE_USER_PRINCIPAL_NAME = 9
Dim strNTUserName
Const ADS_NAME_INITTYPE_DOMAIN = 1
Const ADS_NAME_TYPE_UNKNOWN = 8
Const ADS_NAME_TYPE_CANONICAL = 2

Dim oTrans
Set oTrans = CreateObject("NameTranslate")
wscript.Echo Err.Description

' Pull Environment variables for domain/user
strNTDomain = WshShell.ExpandEnvironmentStrings("%USERDOMAIN%")
strNTUserName = ucase(WshShell.ExpandEnvironmentStrings("%USERNAME%"))

GetInfo
Main 

IEMessage strMessage,"NT User Info for " &  strNTUserName,"lt Blue",650,850,True


' ======== Functions and Subs ==========
Sub GetInfo() 
	If WScript.arguments.Count = 1 Then 
	strUserName = WScript.Arguments(0)
	Else
		strUserName = InputBox("Get information on what user account?  (Enter NT Name or UPN)","Account Name",strNTDomain & "\" & strNTUserName)
	End If 
	If strUserName = "" Then WScript.Quit

	strUserName = trim(strUsername)
	If InStr(strUserName,"@") Then 
		strUPN = strUserName
		strUserName = GetNTPath(strUserName)
	End If 	

	strUserName = Replace(strUserName,"/","\")
	If InStr(strUserName,"\") Then  
		Dim tArray
		tArray = Split(strUserName,"\")
		strNTDomain = tArray(0)
		strNTUserName = tArray(1)
	Else
		strNTUserName = strUserName
	End If
		
	If Len(strUPN) = 0 Then strUPN = GetUPN(strNTDomain & "\" & strNTUserName)

	'Attempt to bind to the user
	Set objUser = GetObject("WinNT://"& strNTDomain & "/" & strNTUserName & ", user")
	
	If Err <> 0 Then
	' Lets see if anyone matches strNTUserName first 4 characters...
	dim objFindUser: Set objFindUser = GetObject("WinNT://"& strNTDomain)
	dim user
	strNTUserName = UCase(strNTUserName)	' has to be uppercase
		For Each User In objFindUser	'search thru the domain users list
			If Left(User.Name, 4) = Left(strNTUserName, 4) Then
				strUserList = strUserList & User.Name & vbTab & User.Fullname & vbCrLf
			End If
		Next
			' show list of matching users if any at all
			strMsgNoUser =  "Error: Could not find: " & vbCrLf _
				& VbCrLf & "WinNT://" & strNTDomain &"/"& strNTUserName & vbCrLf & vbCrLf
			strMsgNoUser = strMsgNoUser & "Perhaps you meant one of these: " & vbCrLf & vbCrLf & strUserList
			WshShell.Popup strMsgNoUser,0,"Error retrieving information",vbCritical
		
			' Evaluate the user input in case they want to quit
			If strNTUserName = "" Then    ' Cancelled by the user
			    WScript.quit
			End If
	strUserList = ""
	GetInfo
	End If 
End Sub

Sub Main()
	'Much of this is the original RM code

	' Determine how many passwords are saved
	Set oDomain = GetObject("WinNT://" & strNTDomain)
	
	Dim  intPwdHistory 
	intPwdHistory = oDomain.PasswordHistoryLength
	iAutoUnlock = oDomain.AutoUnlockInterval/60
	Dim iAdminCount, dPwdLastChanged, iAutoUnlock
	
	On Error Resume Next
	' Creates the list of goups the user belongs To
	For Each objGroup In objUser.Groups
		If strGroupList = "" Then
			strGroupList = objGroup.Name
		Else
			strGroupList = strGroupList & ", " & objGroup.Name
		End If
	Next
	' Convert strgrouplist to Array
	arrGroupList = Split(strGroupList,",")
	'Sort the durn thing
	Quicksort arrGroupList, LBound(arrGroupList), UBound(arrGroupList)
	' Now concatenate arrGroupList into a variable for display
	strSortedGroups = trim(Join(arrGroupList, ", "))
	
	'check for expired password
	intPwdExpired = objUser.Get("PasswordExpired")
	
	If intPwdExpired = 1 Then
		bPwdExpired = True
	Else 
		bPwdExpired = False
	End If
		
	'Check for Must Change Password Flag
	objFlags = objUser.Get("UserFlags")
	If (objFlags And &H00040) <> 0 Then
		bCanChangePW = False
	Else 
		bCanChangePW = True
	End If
		
	'check for smartcard required
	If (objFlags And  &H40000) <> 0 Then
		bSCRqd = True
	Else 
		bSCRqd = False
	End If
	
	
	' Is password set to NEVER expire?	
	If (objFlags And &H10000) <> 0 Then
		bPWNeverExpires = True 
		strPwdExpires = "Date Set: "
	Else 
		bPWNeverExpires = False
		strPwdExpires = "Password Expires: "
	End If
		
	' Is the account disabled?
	bAccountDisabled = objUser.AccountDisabled
		
	'How many wrong logins?
	'Dim iBadLogins
	iBadLogins = objUser.BadPasswordAttempts
	
	'Maximum bad password attempts?
	iMaxPadPw = objUser.MaxBadPasswordsAllowed	
	
	'Account Lockout Observation Interval
	iAccountLockout = FormatNumber((objUser.LockoutObservationInterval/60), 0)
	
	' How old is the current password?
	iPwdAge = FormatNumber(((objUser.Get("PasswordAge")/60)/60)/24, 0)
	
	' Calculate the date the password was last changed
	dPwdLastChanged = CStr(objUser.PasswordExpirationDate - objUser.Get("MaxPasswordAge") / (60 * 60 * 24))
	

	iAdminCount = objUser.Get("AdminCount")
	Err.Clear
	
	If IsEmpty(iAdminCount) Or  (iAdminCount = 0) Then 
		bAdmin = False
	Else
		bAdmin = True
	End If 
	
	If  IsEmpty((objUser.Profile)) Or  len(objUser.Profile) = 0 Then 
		strProfile = "Not Set"
	Else 
		strProfile = objUser.Profile
	End If
	
	'build the message
	strMessage = "Full Name: " & objUser.FullName & vbCrLf &_
	"NT4Name: " & strNTDomain & "\"  & strNTUserName & VbCrLf  & _
	"UPN: " & strUPN & VbCrLf & _
	"Description: " & objUser.Description & VbCrLf & VbCrLf & _
	"Smart Card Required: " & bSCRqd  & VbCrLf & _
	"Account Locked Out: " & objUser.IsAccountLocked & vbcrlf  & _
	"Account Disabled: " & bAccountDisabled & VbCrLf
	strMessage = strMessage &  "Bad Logins: " & iBadLogins & VbCrLf & _
	"~ Last logon: " & objUser.LastLogin & vbCrLf
	strMessage = strMessage & "Max password attempts: " & iMaxPadPw  & _
	", attempts left: " & iMaxPadPw - iBadLogins & vbCrLf & vbCrLf
	
	If Not bCanChangePW Then 
		strMessage = strMessage & "User cannot change password." & VbCrLf 
	End If 
	
	If Not bPWNeverExpires Then
		If bPwdExpired Then 
			strMessage = strMessage & "Password expired" & VbCrLf 
		Else 
			strMessage = strMessage & strPwdExpires & Space(1) & objUser.PasswordExpirationDate & VbCrLf & _		
			"Password Last Changed: " & dPwdLastChanged & VbCrLf & _ 
			"Password Age: " & iPwdAge & " days" & VbCrLf 
		End If 
	Else
		strMessage = strMessage & "Password never expires" & VbCrLf 
	End If 

'	Omit standard domain data about password 
' 	strmessage = strMessage & "Password Minimum Length: " & objUser.PasswordMinimumLength & VbCrLf & _
' 	"Passwords Kept In History: "  & intPwdHistory & " password(s). " & VbCrLf  & _
' 	"Lockout Time: " & iAccountLockout & " minutes. AutoUnlock: " & iAutoUnlock & " minutes" & vbCrLf & VbCrLf

	Dim strLogonScript:	strLogonScript = objUser.LoginScript 
	Err.Clear
	If IsEmpty(strLogonScript) or len(strLogonScript) = 0 Then strLogonScript = "Not Set"
	
	Dim strHomeDir: strHomeDir = objUser.HomeDirectory
	Err.Clear
	If IsEmpty(strHomeDir) or len(strLogonScript) =0 Then strHomeDir = "Not Set"
	
	strMessage = strMessage & "Logon Script: " & strLogonScript& VbCrLf & _
	"Home Directory: " & strHomeDir & vbCrLf
	
	strMessage = strMessage & "Admin Bit Count Set? " & bAdmin & vbcrlf
	strMessage = strMessage & "User Profile Path: " & strProfile & VbCrLf & VbCrLf 
	strMessage = strMessage & "Groups: " & strSortedGroups
End Sub 


Function Copy2Clip(strMessage)
	Dim objWord
 	'Sets what you want to put in the clipboard using Word object
	'Variation of code by Tony Bothwell, posted at
	'http://stackoverflow.com/questions/128463/use-clipboard-from-vbscript
	
	' Declare an object for the word application  
	On Error Resume Next
	Set objWord = CreateObject("Word.Application")
	If Err = 0 Then 
		' Using the object
		With objWord    
			.Visible = False             	' Don't show Word
			.Documents.Add               	' Create a document
			.Selection.TypeText strMessage	' Put text into it    
			.Selection.WholeStory        	' Select everything in the doc
			.Selection.Copy              	' Copy contents to clipboard    
			.Quit False                  	' Close Word, don't save
		End With
		WshShell.Popup "User data copied to clipboard",15,"Done"
	Else
		Err.Clear
		If(MsgBox ("Could not copy to clipboard, send to notepad instead?",_
			vbYesNo + vbQuestion, "Send to Notepad") = vbYes) then
			wshshell.Run("notepad.exe")
			
			While wshshell.appactivate("Untitled - Notepad") = False
				Wscript.Sleep 10
			Wend
			
			wshshell.SendKeys strMessage
		End If 
	End If 
	On Error GoTo 0
End Function 


' Sorts the items in the array (between the two values you pass in).
Sub Quicksort(strValues(), ByVal min, ByVal max)

	Dim strMediumValue, high, low, i

	'If the list has only 1 item, it's sorted.
	If min >= max Then Exit Sub

	' Pick a dividing item randomly.
	i = min + Int(Rnd(max - min + 1))
	strMediumValue = strValues(i)

	' Swap the dividing item to the front of the list.
	strValues(i) = strValues(min)

	' Separate the list into sublists.
	low = min
	high = max
	Do
		' Look down from high for a value < strMediumValue.
		Do While strValues(high) >= strMediumValue
			high = high - 1
			If high <= low Then Exit Do
		Loop

		If high <= low Then
			'The list is separated.
			strValues(low) = strMediumValue
			Exit Do
		End If

		'Swap the low and high strValues.
		strValues(low) = strValues(high)

		'Look up from low for a value >= strMediumValue.
		low = low + 1
		Do While strValues(low) < strMediumValue
			low = low + 1
			If low >= high Then Exit Do
		Loop

		If low >= high Then
			'The list is separated.
			low = high
			strValues(high) = strMediumValue
			Exit Do
		End If

		'Swap the low and high strValues.
		strValues(high) = strValues(low)
	Loop 'Loop until the list is separated.

	'Recursively sort the sublists.
	Quicksort strValues, min, low - 1
	Quicksort strValues, low + 1, max

End Sub

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,"<br>"& vbcrlf)
	message = Replace(message,vbTab,"&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;")

	Do While (oIE.Busy)
		Wscript.Sleep 250
	Loop
	
	Set oPage = oIE.Document
	oPage.Open

	oPage.Writeln "<html><head><title>" & strTitle & "</title></head>"
	oPage.Writeln "<body bgcolor='"& strBGcolor & "'>"
	oPage.Writeln "<Font face ='"& strFont & "'>"
	oPage.Writeln "<Center><h2>" & strTitle & "</center></h2>"
	oPage.Writeln "<Span>" & Message & "</Span><br><br>"
	If bPrint Then 
		oPage.WriteLn "<input id=runbutton  type='button' value='Print' name='printbtn' onClick='window.print();'>"
	End If 
	oPage.writeln "<br>Script version " & strVer
	oPage.Writeln "</font></body></html>"
	oPage.Write()
	oPage.Close 
End Sub



Function GetUPN (strNTName)
	On Error Resume Next 
	oTrans.Init ADS_NAME_INITTYPE_GC, ""
	oTrans.Set ADS_NAME_TYPE_UNKNOWN,strNTName
		If Err <> 0 Then 
		MsgBox "Unable to lookup " & strNTName,vbCritical + vbOKOnly,"Error"
		WScript.Quit
	End If 
	GetUPN = oTrans.Get(5)
End Function 

Function GetNTPath (strUPN)
	On Error Resume next
	oTrans.Init ADS_NAME_INITTYPE_GC, ""
	oTrans.Set ADS_NAME_TYPE_USER_PRINCIPAL_NAME,strUPN
	If Err <> 0 Then 
		MsgBox "Unable to lookup " & strUPN,vbCritical + vbOKOnly,"Error"
		WScript.Quit
	End If 
	
	GetNTPath  =  oTrans.Get(ADS_NAME_TYPE_NT4)
	GetNTPath = Replace(GetNTPath,"\","/")
End Function