'=========================================================================
' DeleteOldUsers.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' 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 = "alert.admin@domain.com" '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
