DeleteOldUsers.vbs

'=========================================================================
' 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