Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 486
  • Last Modified:

VBScript: Enumerating Specific Accounts within AD

Hi Experts!

     I think this has become my favorite zone as much as I'm here  : )

     I'm curious, does anyone have a script already or can provide suggestion how to pull this information I'm needing into a report i.e. .csv file?  I'm needing to pull all ACTIVE ACCOUNTS in AD that begin with the following prefix:  "NPS"  NPS accounts are contractors within the company and the standard naming convention is NPSjohndoe or NPS12345678 ect... NPS is always first though.

      Then once the script has identified all of the ACTIVE NPS accounts, it then determines by looking at the Expire date which NPS accounts that are about to expire in 30 days.  For the accounts the script hits on that are about to expire it then provides the Manager field info for that account.  Lastly, it then sends an automated email to that manager notifying them that "Hey your NPS employee's account is about to expire.  Please confirm their information." in the body...  Is this possible?

So to re-cap:

* Pulls all Active NPS accounts in AD.
* Indentify's which NPS accounts that are about to expire in 30 days.
* Pulls the manager field value for those accounts it identify's that are about to expire.
* Lastly builds a report and automatically emails that manager based off of that managers email in the properties of the NPS account.  The email will inform the Manager that their NPS employees account is about to expire.

 Chart
0
itsmevic
Asked:
itsmevic
  • 12
  • 9
1 Solution
 
RobSampsonCommented:
Hi, let's try this first to get active accounts that start with NPS (samaccountname). We'll build on that...

Regards,

Rob.
strResults = "ActiveUsers.csv"

arrOUs = Array( _
	"OU=UserAccounts,OU=Office1," _
	)

Set objRootDSE = GetObject("LDAP://RootDSE")
strDomain = objRootDSE.Get("defaultNamingContext")
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand =   CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection

objCommand.Properties("Page Size") = 1000

Set objResults = objFSO.CreateTextFile(strResults, True)
For Each strOU In arrOUs
	If Right(strOU, 1) <> "," Then strOU = strOU & ","
	strCommandText = "<LDAP://" & strOU & strDomain & ">; (&(objectCategory=person)(objectClass=user)(samAccoutName=nps*)(!(userAccountControl:1.2.840.113556.1.4.803:=2)));adsPath,samAccountName;Subtree"  
	objCommand.CommandText = strCommandText
	Set objRecordSet = objCommand.Execute
	Do Until objRecordSet.EOF
		strSamAccountName = objRecordSet.Fields("samAccountName").Value
		objResults.WriteLine strSamAccountName
	    objRecordSet.MoveNext
	Loop
Next
objResults.Close

MsgBox "Finished. Please see " & strResults

Open in new window

0
 
itsmevicAuthor Commented:
Hey there Rob!  After running the script above I'm getting the following error:

*****************************************************************************
Script:  C:\xxxx\xxxxxxx\desktop\ActiveUsers.vbs                  
Line:     16                                                                                  
Char:     1
Error:     Object required 'objFSO'
Code:     800A01A8
Source:  Microsoft VBScript runtime error

*****************************************************************************
                                                                                   *     OK      *
                                                                                   **************


Thanks again for help.  You are appreciated!
0
 
RobSampsonCommented:
Ooops, I took out
Set objFSO = CreateObject("Scripting.FileSystemObject")

Please add that above
Set objResults = objFSO.CreateTextFile(strResults, True)


Rob.
0
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
itsmevicAuthor Commented:
Stubborn code tonight huh?....LOL  

Looks like it's erroring out on me again.  
*******************************************************
Line: 30
Char: 1
Error:  Object required: 'objResults'
Code:  800A01A8
Source: Microsoft VBScript runtime error
*******************************************************
0
 
RobSampsonCommented:
That's odd.   That's on this line:
objResults.Close

which doesn't make sense......it's been created and written to....

Have you added any extra code?

Rob.
0
 
itsmevicAuthor Commented:
I'll try it again and let you know.  Maybe shifted something out of place accidentally.
0
 
itsmevicAuthor Commented:
Really weird, it's erroring out on objResults.Close line for some reason...  The only thing I can think of as to why it would be doing that, maybe, is that you had coded the array to see the OU's as such:

arrOUs = Array( _
      "OU=UserAccounts,OU=Office1," _
      )

I did change it some just to show the top level OU only rather than drilling down into all the sub OU's underneath.  I didn't see a need because you had added the "adsPath,samAccountName;Subtree" path in the code? I'm thinking with the subtree there it automatically tells the script to search under ALL sub OU's under the OU "USERACCOUNTS"  Do you think this is why it's doing that?

This is what I changed it to:

arrOUs = ARray(_
        "OU=UserAccounts," _
         )

Thanks for your patience.  
0
 
RobSampsonCommented:
Hi, sorry for my delay.  Try this.

Regards,

Rob.
strResults = "ActiveUsers.csv"

arrOUs = Array( _
	"OU=TestUsers,OU=TestOU," _
	)

Set objRootDSE = GetObject("LDAP://RootDSE")
strDomain = objRootDSE.Get("defaultNamingContext")
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand =   CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection

objCommand.Properties("Page Size") = 1000

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objResults = objFSO.CreateTextFile(strResults, True)
objResults.WriteLine """samAccountName"",""Account Expiration"",""Manager"""

For Each strOU In arrOUs
	If Right(strOU, 1) <> "," Then strOU = strOU & ","
	strCommandText = "<LDAP://" & strOU & strDomain & ">; (&(objectCategory=person)(objectClass=user)(samAccountName=nps*)(!(userAccountControl:1.2.840.113556.1.4.803:=2)));adsPath,samAccountName;Subtree"
	objCommand.CommandText = strCommandText
	Set objRecordSet = objCommand.Execute
	Do Until objRecordSet.EOF
		strSamAccountName = objRecordSet.Fields("samAccountName").Value
		Set objUser = GetObject(objRecordSet.Fields("adsPath").Value)
		On Error Resume Next
		dteExpiration = objUser.AccountExpirationDate
		If Not (dteExpiration = "1/1/1970" Or objUser.AccountExpirationDate = "1/01/1601 10:00:00 AM" Or Err.Number = -2147467259) Then
			Err.Clear
			On Error Goto 0
			If DateDiff("d", Date, dteExpiration) <= 30 Then
				objResults.WriteLine """" & strSamAccountName & """,""" & dteExpiration & """,""" & objUser.ManagedBy & """"
			End If
	    	objRecordSet.MoveNext
	    End If
	    Err.Clear
	    On Error Goto 0
	Loop
Next
objResults.Close

MsgBox "Finished. Please see " & strResults

Open in new window

0
 
itsmevicAuthor Commented:
Hey there Rob!  Ran the latest script, good news! it's not erroring out.  It produces the csv file with the three columns specified in the script but it's not producing any data.  I went to the Task Manager and see the process wscript.exe running, but it's been running now for an hour or two and isn't populating the .csv file with any data for some reason.  I thought, I'd let it run a little longer, I was thinking perhaps it was because I'm working over the VPN and that it might be a bandwidth thingy.  I may wait and just run it again tomorrow when I'm plugged into the LAN to see if that makes a difference.  

Also, I changed the the first part of the script to look at the parent OU only, rather than nailing it down to the dozens and dozens of sub OU's underneath.  It presently looks like this, not sure if this is why it's taking so long or not...

arrOUs = Array( _
      "OU=UserAccounts," _
      )
0
 
RobSampsonCommented:
Hmmm, it would take a while if you've got thousands of accounts, you're right, the subtree means it will search any OU deeper than the one you specify.

Maybe, just for testing, specify one deeper down that has less accounts, and see if it finishes.  It worked for me...

Rob.
0
 
itsmevicAuthor Commented:
I'll give it a shot and let you know.  Thanks again for all your help!
0
 
itsmevicAuthor Commented:
HI Rob, I'm experimenting with it now and will let you know.  I was informed that searching by UPN rather than samAccountName in this query would produce more accurate results.  I changed the LDAP filter to reflect:

strCommandText = "<LDAP://" & strOU & strDomain & ">; (&(objectCategory=person)(objectClass=user)(userPrincipalName=nrp*)(!(userAccountControl:1.2.840.113556.1.4.803:=2)));adsPath,samAccountName;Subtree"

But was not sure if I needed to change anything else in the script.  Wanted to run it by you.
0
 
RobSampsonCommented:
You wouldn't need to change anything else if you want to output the samAccountName (which by the sounds of it might be slightly different).  If you wanted to output the userprincipalname, just change all instances of samaccountname in the script to userprincipalname.

Regards,

Rob.
0
 
RobSampsonCommented:
OK, try this.  It should be a fully functional script.  Just change the variables at the top, and it should:
1) Query for all ACTIVE accounts only, that have a UPN beginning with NPS
2) For each of those, determine whether their expiry date is within 30 days
3) Is it is, determine the expiring accounts manager, obtain they're email address, and email them
4) Write the details to a CSV file

Regards,

Rob.
' Email variables:
strServer = "mailhost.abc.com"
strFrom = "john.doe@abc.com"
strSubject = "User Accounts Expiring"

strResults = "ActiveUsers.csv"

arrOUs = Array( _
	"OU=TestUsers,OU=TestOU," _
	)

Set objRootDSE = GetObject("LDAP://RootDSE")
strDomain = objRootDSE.Get("defaultNamingContext")
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand =   CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection

objCommand.Properties("Page Size") = 1000

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objResults = objFSO.CreateTextFile(strResults, True)
objResults.WriteLine """userPrincipalName"",""Account Expiration"",""Manager"",""Manager Email"""

For Each strOU In arrOUs
	If Right(strOU, 1) <> "," Then strOU = strOU & ","
	strCommandText = "<LDAP://" & strOU & strDomain & ">; (&(objectCategory=person)(objectClass=user)(userPrincipalName=nps*)(!(userAccountControl:1.2.840.113556.1.4.803:=2)));adsPath,userPrincipalName;Subtree"
	objCommand.CommandText = strCommandText
	Set objRecordSet = objCommand.Execute
	Do Until objRecordSet.EOF
		strUPN = objRecordSet.Fields("userPrincipalName").Value
		Set objUser = GetObject(objRecordSet.Fields("adsPath").Value)
		On Error Resume Next
		dteExpiration = objUser.AccountExpirationDate
		If Not (dteExpiration = "1/1/1970" Or objUser.AccountExpirationDate = "1/01/1601 10:00:00 AM" Or Err.Number = -2147467259) Then
			Err.Clear
			On Error Goto 0
			If DateDiff("d", Date, dteExpiration) <= 30 Then
				strManager = objUser.Manager
				If strManager <> "" Then
					Set objManager = GetObject("LDAP://" & strManager)
					strManager = Mid(Split(strManager, ",")(0), 4)
					strEmail = objManager.mail
					Set objManager = Nothing
				Else
					strEmail = ""
				End If
				objResults.WriteLine """" & strUPN & """,""" & dteExpiration & """,""" & strManager & """,""" & strEmail & """"
				If strEmail <> "" Then
					strTo = strEmail
					strBody = "Your NPS employee's account is about to expire:" & VbCrLf & "Username: " & strUPN & VbCrLf & "Expiry: " & dteExpiration
					SendEmail strServer, strTo, strFrom, strSubject, strBody, ""
				End If
			End If
	    	objRecordSet.MoveNext
	    End If
	    Err.Clear
	    On Error Goto 0
	Loop
Next
objResults.Close

MsgBox "Finished. Please see " & strResults

Sub SendEmail(strServer, strTo, strFrom, strSubject, strBody, strAttachment)
        Dim objMessage
        
        Set objMessage = CreateObject("CDO.Message")
        objMessage.To = strTo
        objMessage.From = strFrom
        objMessage.Subject = strSubject
        objMessage.TextBody = strBody
  		If strAttachment <> "" Then objMessage.AddAttachment strAttachment
  		
        '==This section provides the configuration information for the remote SMTP server.
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        'Name or IP of Remote SMTP Server
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strServer
        'Server port (typically 25)
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25      
        objMessage.Configuration.Fields.Update
        '==End remote SMTP server configuration section==
 
        objMessage.Send
        Set objMessage = Nothing
End Sub

Open in new window

0
 
itsmevicAuthor Commented:
Will run this Rob and let you know.  Thanks again for all your help man!  
0
 
itsmevicAuthor Commented:
The script is running great it appears, no errors, it's producing the .CSV file.  However, it's still not producing any data in the spreadsheet and this is due to it just taking forever to run.  We have roughly  100k users in AD that it's scanning on, so I know that's why it's taking so long but you'd think it would bring back a few hits.  Is there a way to change the array to search at the top level domain, i.e. at the dc=abc,dc=abc,dc=com?    

Anyway, the script is solid, just not sure if the time it's taking is due to the shear nujmber of users or if it's the way the arrays I'm searching in are coded in.  Not sure.  Still working with it.  Again thank you for all you help!  
0
 
RobSampsonCommented:
Ok, try this to give you some idea of progress.  It will display the name of each enumerated account so you can see what's going on.

Regards,

Rob.
If LCase(Right(Wscript.FullName, 11)) = "wscript.exe" Then
    strPath = Wscript.ScriptFullName
    strCommand = "%comspec% /c cscript  """ & strPath & """"
    Set objShell = CreateObject("Wscript.Shell")
    objShell.Run(strCommand), 1, True
    Wscript.Quit
End If

' Email variables:
strServer = "mailhost.abc.com"
strFrom = "john.doe@abc.com"
strSubject = "User Accounts Expiring"

strResults = "ActiveUsers.csv"

arrOUs = Array( _
	"OU=TestUsers,OU=TestOU," _
	)

Set objRootDSE = GetObject("LDAP://RootDSE")
strDomain = objRootDSE.Get("defaultNamingContext")
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand =   CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection

objCommand.Properties("Page Size") = 1000

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objResults = objFSO.CreateTextFile(strResults, True)
objResults.WriteLine """userPrincipalName"",""Account Expiration"",""Manager"",""Manager Email"""

For Each strOU In arrOUs
	If Right(strOU, 1) <> "," Then strOU = strOU & ","
	strCommandText = "<LDAP://" & strOU & strDomain & ">; (&(objectCategory=person)(objectClass=user)(userPrincipalName=nps*)(!(userAccountControl:1.2.840.113556.1.4.803:=2)));adsPath,userPrincipalName;Subtree"
	objCommand.CommandText = strCommandText
	Set objRecordSet = objCommand.Execute
	Do Until objRecordSet.EOF
		strUPN = objRecordSet.Fields("userPrincipalName").Value
		Set objUser = GetObject(objRecordSet.Fields("adsPath").Value)
		On Error Resume Next
		dteExpiration = objUser.AccountExpirationDate
		If Not (dteExpiration = "1/1/1970" Or objUser.AccountExpirationDate = "1/01/1601 10:00:00 AM" Or Err.Number = -2147467259) Then
			Err.Clear
			On Error Goto 0
			If DateDiff("d", Date, dteExpiration) <= 30 Then
				WScript.Echo strUPN & " - expires " & dteExpiration & " - writing to file..."
				strManager = objUser.Manager
				If strManager <> "" Then
					Set objManager = GetObject("LDAP://" & strManager)
					strManager = Mid(Split(strManager, ",")(0), 4)
					strEmail = objManager.mail
					Set objManager = Nothing
				Else
					strEmail = ""
				End If
				objResults.WriteLine """" & strUPN & """,""" & dteExpiration & """,""" & strManager & """,""" & strEmail & """"
				If strEmail <> "" Then
					strTo = strEmail
					strBody = "Your NPS employee's account is about to expire:" & VbCrLf & "Username: " & strUPN & VbCrLf & "Expiry: " & dteExpiration
					SendEmail strServer, strTo, strFrom, strSubject, strBody, ""
				End If
			Else
				WScript.Echo strUPN & " - expires " & dteExpiration & " - not writing to file."
			End If
	    	objRecordSet.MoveNext
	    Else
			WScript.Echo strUPN & " - never expires"
	    End If
	    Err.Clear
	    On Error Goto 0
	Loop
Next
objResults.Close

MsgBox "Finished. Please see " & strResults

Sub SendEmail(strServer, strTo, strFrom, strSubject, strBody, strAttachment)
        Dim objMessage
        
        Set objMessage = CreateObject("CDO.Message")
        objMessage.To = strTo
        objMessage.From = strFrom
        objMessage.Subject = strSubject
        objMessage.TextBody = strBody
  		If strAttachment <> "" Then objMessage.AddAttachment strAttachment
  		
        '==This section provides the configuration information for the remote SMTP server.
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        'Name or IP of Remote SMTP Server
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strServer
        'Server port (typically 25)
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25      
        objMessage.Configuration.Fields.Update
        '==End remote SMTP server configuration section==
 
        objMessage.Send
        Set objMessage = Nothing
End Sub

Open in new window

0
 
itsmevicAuthor Commented:
I'll give it a go and let you know.  Thanks Rob!
0
 
itsmevicAuthor Commented:
Ok, I found what might be holding it up now that I can see the files actually being processed.  It's getting hung up on NPS accounts that are set already to "NEVER EXPIRE"  once these are corrected the script progresses forward until it hits another NPS account that set to NEVER EXPIRE and it repeats the process.  This why it's hanging.  The email notification works like a charm.  Just had manager contacft me in regard to the ntofication that was just sent to them.  

These type of accounts are not suppose to be set to NEVER EXPIRE so I think this script caught those inadvertently, which of course is a good thing.....however these NON EXPIRING accounts are causing the script to hang which turn turn causes the loop to invariably stop.
0
 
itsmevicAuthor Commented:
Great input Rob, thanks again for all your help!
0
 
RobSampsonCommented:
Oh I see why!  Just move the objRecordset.MoveNext down a few lines.  This should fix it.

Thanks for the grade.

Regards,

Rob.
If LCase(Right(Wscript.FullName, 11)) = "wscript.exe" Then
    strPath = Wscript.ScriptFullName
    strCommand = "%comspec% /c cscript  """ & strPath & """"
    Set objShell = CreateObject("Wscript.Shell")
    objShell.Run(strCommand), 1, True
    Wscript.Quit
End If

' Email variables:
strServer = "mailhost.abc.com"
strFrom = "john.doe@abc.com"
strSubject = "User Accounts Expiring"

strResults = "ActiveUsers.csv"

arrOUs = Array( _
	"OU=TestUsers,OU=TestOU," _
	)

Set objRootDSE = GetObject("LDAP://RootDSE")
strDomain = objRootDSE.Get("defaultNamingContext")
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand =   CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection

objCommand.Properties("Page Size") = 1000

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objResults = objFSO.CreateTextFile(strResults, True)
objResults.WriteLine """userPrincipalName"",""Account Expiration"",""Manager"",""Manager Email"""

For Each strOU In arrOUs
	If Right(strOU, 1) <> "," Then strOU = strOU & ","
	strCommandText = "<LDAP://" & strOU & strDomain & ">; (&(objectCategory=person)(objectClass=user)(userPrincipalName=nps*)(!(userAccountControl:1.2.840.113556.1.4.803:=2)));adsPath,userPrincipalName;Subtree"
	objCommand.CommandText = strCommandText
	Set objRecordSet = objCommand.Execute
	Do Until objRecordSet.EOF
		strUPN = objRecordSet.Fields("userPrincipalName").Value
		Set objUser = GetObject(objRecordSet.Fields("adsPath").Value)
		On Error Resume Next
		dteExpiration = objUser.AccountExpirationDate
		If Not (dteExpiration = "1/1/1970" Or objUser.AccountExpirationDate = "1/01/1601 10:00:00 AM" Or Err.Number = -2147467259) Then
			Err.Clear
			On Error Goto 0
			If DateDiff("d", Date, dteExpiration) <= 30 Then
				WScript.Echo strUPN & " - expires " & dteExpiration & " - writing to file..."
				strManager = objUser.Manager
				If strManager <> "" Then
					Set objManager = GetObject("LDAP://" & strManager)
					strManager = Mid(Split(strManager, ",")(0), 4)
					strEmail = objManager.mail
					Set objManager = Nothing
				Else
					strEmail = ""
				End If
				objResults.WriteLine """" & strUPN & """,""" & dteExpiration & """,""" & strManager & """,""" & strEmail & """"
				If strEmail <> "" Then
					strTo = strEmail
					strBody = "Your NPS employee's account is about to expire:" & VbCrLf & "Username: " & strUPN & VbCrLf & "Expiry: " & dteExpiration
					SendEmail strServer, strTo, strFrom, strSubject, strBody, ""
				End If
			Else
				WScript.Echo strUPN & " - expires " & dteExpiration & " - not writing to file."
			End If
	    Else
			WScript.Echo strUPN & " - never expires"
	    End If
	    Err.Clear
	    On Error Goto 0
    	objRecordSet.MoveNext
	Loop
Next
objResults.Close

MsgBox "Finished. Please see " & strResults

Sub SendEmail(strServer, strTo, strFrom, strSubject, strBody, strAttachment)
        Dim objMessage
        
        Set objMessage = CreateObject("CDO.Message")
        objMessage.To = strTo
        objMessage.From = strFrom
        objMessage.Subject = strSubject
        objMessage.TextBody = strBody
  		If strAttachment <> "" Then objMessage.AddAttachment strAttachment
  		
        '==This section provides the configuration information for the remote SMTP server.
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        'Name or IP of Remote SMTP Server
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strServer
        'Server port (typically 25)
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25      
        objMessage.Configuration.Fields.Update
        '==End remote SMTP server configuration section==
 
        objMessage.Send
        Set objMessage = Nothing
End Sub

Open in new window

0

Featured Post

Hire Technology Freelancers with Gigs

Work with freelancers specializing in everything from database administration to programming, who have proven themselves as experts in their field. Hire the best, collaborate easily, pay securely, and get projects done right.

  • 12
  • 9
Tackle projects and never again get stuck behind a technical roadblock.
Join Now