'========================================================================= ' DeleteOldUsers.vbs ' VERSION: 1.0 ' AUTHOR: Brian Steinmeyer ' EMAIL: [email protected] ' WEB: https://sigkillit.com ' DATE: 4/22/2014 ' USER TERMINATION POLICY: ' - Reset PW ' - Set description to termination date ' - Optionally forward email ' - Move terminated users to specified OU ' COMMENTS: This script works in conjunction with the above user termination ' policy. Specify the OU containing old users and set the number of retention ' days to keep an AD user account after the termination date. You can schedule ' the script to run daily to delete any old users. to permanently delete ' those users after X amount of days. '========================================================================= Option Explicit ' ------ SCRIPT CONFIGURATION ------ Dim oldUserOU: oldUserOU = "OU=Old Users,OU=User,DC=domain,DC=local" Dim oldUserRetentionDays: oldUserRetentionDays = 30 Dim logResults: logResults = Replace(WScript.ScriptFullName,".vbs","_logs\") & Replace(WScript.ScriptName,".vbs","_") & FixDate(Date()) & Replace(FormatDateTime(Time,4), ":", "") & ".txt" Dim logRetentionDays: logRetentionDays = 30 Dim emailBlatExe: emailBlatExe = "c:\blat\blat.exe" 'Custom Path to Blat.exe Default is Same Folder as Script Dim emailProfile: emailProfile = "alert" 'Blat Profile Name See (http://www.blat.net) For Info Dim emailRecipient: emailRecipient = "[email protected]" 'Email to Receive Backup Result Dim blnEmailOnlyOnDelete: blnEmailOnlyOnDelete = true 'True = Only email results when at least 1 user is deleted ' ------ END CONFIGURATION ------ 'MAIN CALLS Call TerminateOldUsers(oldUserRetentionDays,oldUserOU,logResults) Call SendResults(logResults,blnEmailOnlyOnDelete,emailBlatExe,emailProfile,emailRecipient) Call PurgeLogs(Replace(WScript.ScriptFullName,".vbs","_logs\"),logRetentionDays,".txt") ' *************************************************************************************************** ' Sub TerminateOldUsers - Parse Old Users and Delete after X days ' *************************************************************************************************** Private Sub TerminateOldUsers(intDays,strOU,logName) On Error Resume Next 'Start Error Handling 'Create Log File Call Logger(logName, "DATE:" & Now() & vbCrLf & "USER_OU:" & strOU & vbCrLf & "RETENTION_DAYS:" & intDays, True) 'Search OU For Users Dim objConnection: Set objConnection = CreateObject("ADODB.Connection") Dim objCommand: Set objCommand = CreateObject("ADODB.Command") objConnection.Provider = "ADsDSOObject" objConnection.Open "Active Directory Provider" Set objCommand.ActiveConnection = objConnection objCommand.Properties("Page Size") = 1000 'Override the Return 1000 Results Default Const ADS_SCOPE_SUBTREE = 2 objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE 'Include Sub OU's objCommand.CommandText = "SELECT ADsPath, cn FROM 'LDAP://" & strOU & "' WHERE objectCategory='person' AND objectClass='user'" Dim objRecordSet: Set objRecordSet = objCommand.Execute 'Parse Users If objRecordSet.RecordCount > 0 Then objRecordSet.MoveFirst Dim objUser, objParent, strDescription Dim strResult: strResult = "" Do Until objRecordSet.EOF Set objUser = GetObject(objRecordSet.Fields("ADsPath").Value) strDescription = objUser.description If strDescription = "" Then strDescription = "BLANK" End If 'Only Evaluate Users with Date for Description If IsDate(objUser.Description) Then If DateDiff("d",objUser.Description,Date) > intDays Then 'Delete User Past Retention Date strResult = "DELETE" Set objParent = GetObject(objUser.Parent) objParent.Delete "user", "CN=" & objRecordSet.Fields("cn").Value Else strResult = "IGNORE" End If Else strResult = "IGNORE" End If 'Log Results If Err.Number <> 0 Then Err.Clear strResult = "!~ERROR!~" End If Call Logger(logName, strResult & ":(" & strDescription & "):" & objRecordSet.Fields("ADsPath").Value, False) objRecordSet.MoveNext Loop Else Call Logger(logName, "NOUSERS:" & strOU, False) End If On Error Goto 0 'End Error Handling End Sub ' ***************************************************************** ' Sub SendResults - Parse Log File and Send Results ' ***************************************************************** Private Sub SendResults(logName, blnEmail, emailBlatExe, emailProfile, emailRecipient) On Error Resume Next ' Create Objects Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject") 'Parse Log File Dim intDelete: intDelete = 0 Dim intTotal: intTotal = 0 Dim intError: intError = 0 Dim strLine Dim logFile: Set logFile = objFSO.OpenTextFile(logName, 1) Do Until logFile.AtEndOfStream strLine = logFile.ReadLine If InStr(1, strLine, "IGNORE:", 1) Then intTotal = intTotal + 1 End If If InStr(1, strLine, "DELETE:", 1) Then intTotal = intTotal + 1 intDelete = intDelete + 1 End If If InStr(1, strLine, "!~ERROR~!:", 1) Then intTotal = intTotal + 1 intError = intError + 1 End If If InStr(1, strLine, "NOUSERS:", 1) Then 'No Users End If Loop logFile.Close 'Set Email Subject Dim emailSubject: emailSubject = Replace(WScript.ScriptName,".vbs","") If intError > 0 Then emailSubject = emailSubject & " - Error" Else emailSubject = emailSubject & " - Deleted " & intDelete & " Users" End If 'Set Email Body Dim emailBody: emailBody = "TOTAL USERS: " & intTotal & vbCrLf & _ "ERRORS: " & intError & vbCrLf & _ "DELETED: " & intDelete 'Email Results If blnEmail = true Then If intDelete > 0 Then Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, logName) End If Else Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, logName) End If 'Cleanup Objects Set objFSO = Nothing On Error Goto 0 End Sub ' *************************************************************************************************** ' Function SendBlatEmail - Sends Email Using Blat ' *************************************************************************************************** Private Sub SendBlatEmail(blatPath, blatProfile, strRecipients, strSubject, strBody, strAttachment) 'Need blat.exe, blat.dll, blat.lib On Error Resume Next Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject") Dim objShell: Set objShell = WScript.CreateObject("WScript.Shell") Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\")) 'Ensure Blat Exists If Not objFSO.FileExists(blatPath) Then If Not objFSO.FileExists(scriptPath & "blat.exe") Then Exit Sub Else blatPath = scriptPath & "blat.exe" End If End If 'Set Blat Email Command Dim commandText: commandText = chr(34) & blatPath & chr(34) commandText = commandText & " -p " & chr(34) & blatProfile & chr(34) commandText = commandText & " -to " & strRecipients commandText = commandText & " -subject " & chr(34) & strSubject & " " & chr(34) 'Keep Space to Prevent Escaping the Quote commandText = commandText & " -body " & chr(34) & strBody & " " & chr(34) 'Keep Space to Prevent Escaping the Quote 'Append Attachment(s) If objFSO.FileExists(strAttachment) Then commandText = commandText & " -attach " & chr(34) & strAttachment & chr(34) Else If objFSO.FileExists(scriptPath & strAttachment) Then commandText = commandText & " -attach " & chr(34) & scriptPath & strAttachment & chr(34) End If End If 'Send Blat Email objShell.run commandText, True Set objFSO = Nothing Set objShell = Nothing If Err.Number <> 0 Then Err.Clear End If On Error Goto 0 End Sub ' *************************************************************************************************** ' Sub PurgeLogs - Deletes Old Log FIles ' *************************************************************************************************** Private Sub PurgeLogs(logFolder,intDays,strExtension) On Error Resume Next Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject") Dim objFolder: Set objFolder = objFSO.GetFolder(logFolder) Dim file For Each file In objFolder.Files If StrComp(Right(file.Name, Len(strExtension)),strExtension) = 0 Then If DateDiff("d", file.DateLastModified, Now) > intDays Then objFSO.DeleteFile(file), True End If End If Next Set objFSO = Nothing If Err.Number <> 0 Then Err.Clear End If On Error Goto 0 End Sub ' *************************************************************************************************** ' Function FixDate - Ensures Single Digit Numbers Have 0 In Front ' *************************************************************************************************** Function FixDate(strDate) Dim arrTemp Dim M, D, Y arrTemp = Split(strDate, "/") M = arrTemp(0) D = arrTemp(1) Y = arrTemp(2) If (M>=0) And (M<10) Then M = "0" & M If (D>=0) And (D<10) Then D = "0" & D 'If (Y>=0) And (Y<10) Then Y = "0" & Y FixDate = M & D & Y End Function ' *************************************************************************************************** ' Function Logger ' *************************************************************************************************** Private Sub Logger(fileName, logMessage, blnNewLog) On Error Resume Next Const ForReading = 1, ForWriting = 2, ForAppending = 8 Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject") Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\")) Dim logName If InStr(1,fileName,"\",1) > 0 Then logName = fileName If objFSO.DriveExists(objFSO.GetDriveName(logName)) Then If StrComp(objFSO.GetExtensionName(logName), "", 1) = 0 Then If Not objFSO.FolderExists(logName) Then If objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then objFSO.CreateFolder logName 'Create Folder In Current Path Exit Sub Else Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog) 'Recurse Creating Parent Folder Call Logger(logName, logMessage, blnNewLog) 'Recurse Creating Current Folder Exit Sub End If End If Else If Not objFSO.FileExists(logName) Then If Not objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog) 'Recurse Creating Parent Folder Call Logger(logName, logMessage, blnNewLog) 'Recurse Creating Current Folder End If End If End If End If Else logName = scriptPath & fileName End If Dim logFile If blnNewLog = True Then Set logFile = objFSO.CreateTextFile(logName, True) Else If objFSO.FileExists(logName) Then Set logFile = objFSO.OpenTextFile(logName, ForAppending, True) Else Set logFile = objFSO.CreateTextFile(logName, True) End If End If logFile.WriteLine logMessage logFile.Close Set objFSO = Nothing On Error Goto 0 End Sub
