Category Archives: AD Users

Apr 22

DeleteOldUsers.vbs

Posted on by 
'=========================================================================
' DeleteOldUsers.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://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

 

Mar 20

SyncToy21.vbs

Posted on by 
'=========================================================================
' SyncToy21.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 3/20/20114
' REQUIREMENTS: You must install SyncToy on the Workstation and manually run it to click on
' the agreement statement, otherwise this script will lock up and NEVER back up!!!
'=========================================================================
Option Explicit

' ------ SCRIPT CONFIGURATION ------
Const strContact = "backup@domain.com"
Dim syncToyExe: syncToyExe = ExpandEnv("%PROGRAMFILES%\SyncToy 2.1\SyncToy.exe")
Dim syncToyExeX86: syncToyExeX86 = ExpandEnv("%PROGRAMFILES(X86)%\SyncToy 2.1\SyncToy.exe")
Dim syncToyCmdExe: syncToyCmdExe = ExpandEnv("%PROGRAMFILES%\SyncToy 2.1\SyncToyCmd.exe")
Dim syncToyCmdExeX86: syncToyCmdExeX86 = ExpandEnv("%PROGRAMFILES(X86)%\SyncToy 2.1\SyncToyCmd.exe")
Dim blnAutoRun: blnAutoRun = True
Dim syncOperation: syncOperation = "echo"
Dim strBackupPath: strBackupPath = ExpandEnv("\\server\backups\%USERNAME%\")
Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
' ------ END CONFIGURATION ------

Call Main()

Private Sub Main()

    ' Create Objects
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objShell: Set objShell = CreateObject( "WScript.Shell" )

    ' Set Folders for Backups
    Dim strDocuments: strDocuments = objShell.SpecialFolders("MyDocuments")
    Dim strMusic: strMusic = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\My Music")
    Dim strPictures: strPictures = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\My Pictures")
    Dim strVideos: strVideos = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\My Video")

    ' Ensure Backup Path Ends with Slash
    If Right(strBackupPath,1) <> "\" Then
        strBackupPath = strBackupPath & "\"
    End If

    ' Validate Folders for Backup
    Dim strResult: strResult = ""
    If Not objFSO.FolderExists(strDocuments) Then
        strResult = strResult & "- Missing Documents Folder" & vbCrLf
    End If
    If Not objFSO.FolderExists(strMusic) Then
        strResult = strResult & "- Missing Music Folder" & vbCrLf
    End If
    If Not objFSO.FolderExists(strPictures) Then
        strResult = strResult & "- Missing Pictures Folder" & vbCrLf
    End If
    If Not objFSO.FolderExists(strBackupPath) Then
        strResult = strResult & "- Missing Backup Folder" & vbCrLf
    End If

    ' Validate SyncToy Path
    If Not objFSO.FileExists(syncToyExe) Then
        If Not objFSO.FileExists(syncToyExeX86) Then
            strResult = strResult & "- Missing SyncToy.exe" & vbCrLf
        Else
            syncToyExe = syncToyExeX86
        End If
    End If
    If Not objFSO.FileExists(syncToyCmdExe) Then
        If Not objFSO.FileExists(syncToyCmdExeX86) Then
            strResult = strResult & "- Missing SyncToyCmd.exe" & vbCrLf
        Else
            syncToyCmdExe = syncToyCmdExeX86
        End If
    End If

    ' Ensure Everything Validated
    If strResult <> "" Then
        objShell.Popup "An ERROR occurred backing up your files" & vbCrLf & _
            strResult & vbCrLf & _
            "Please contact " & strContact _
            , 30, "ERROR Backing Up Documents!", vbOkOnly + vbCritical
        Wscript.Quit
    End If

    ' Determine Which Folders To Backup and Prompt to Backup
    Dim intAnswer
    Dim blnDocuments: blnDocuments = True
    Dim blnMusic: blnMusic = False
    Dim blnPictures: blnPictures = False
    Dim blnVideos: blnVideos = False
    If InStr(1,strMusic,strDocuments,1) > 0 AND InStr(1,strPictures,strDocuments,1) > 0 AND InStr(1,strVideos,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
    Elseif InStr(1,strMusic,strDocuments,1) > 0 AND InStr(1,strPictures,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Videos
        intAnswer = objShell.Popup("Do you want to Backup your videos now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnVideos = False
        End If
    Elseif InStr(1,strMusic,strDocuments,1) > 0 AND InStr(1,strVideos,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Pictures
        intAnswer = objShell.Popup("Do you want to Backup your pictures now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnPictures = False
        End If
    Elseif InStr(1,strPictures,strDocuments,1) > 0 AND InStr(1,strVideos,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Music
        intAnswer = objShell.Popup("Do you want to Backup your music now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnMusic = False
        End If
    Elseif InStr(1,strMusic,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Pictures
        intAnswer = objShell.Popup("Do you want to Backup your pictures now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnPictures = False
        End If
         Backup Videos
        intAnswer = objShell.Popup("Do you want to Backup your videos now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnVideos = False
        End If
    Elseif InStr(1,strPictures,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Music
        intAnswer = objShell.Popup("Do you want to Backup your music now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnMusic = False
        End If
        ' Backup Videos
        intAnswer = objShell.Popup("Do you want to Backup your videos now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnVideos = False
        End If
    Elseif InStr(1,strVideos,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Music
        intAnswer = objShell.Popup("Do you want to Backup your music now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnMusic = False
        End If
        ' Backup Pictures
        intAnswer = objShell.Popup("Do you want to Backup your pictures now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnPictures = False
        End If
    Else
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Music
        intAnswer = objShell.Popup("Do you want to Backup your music now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnMusic = False
        End If
        ' Backup Pictures
        intAnswer = objShell.Popup("Do you want to Backup your pictures now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnPictures = False
        End If
        ' Backup Videos
        intAnswer = objShell.Popup("Do you want to Backup your videos now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnVideos = False
        End If
    End If

    'Validate Backup Folder Exists Or Try to Create Them
    strResult = ""
    If blnDocuments = True Then
        If ValidateFolder(strBackupPath & "Documents") = False Then
            strResult = strResult & "- Missing " & strBackupPath & "Documents" & vbCrLf
        End If
    End If
    If blnMusic = True Then
        If ValidateFolder(strBackupPath & "Music") = False Then
            strResult = strResult & "- Missing " & strBackupPath & "Music" & vbCrLf
        End If 
    End If
    If blnPictures = True Then
        If ValidateFolder(strBackupPath & "Pictures") = False Then
            strResult = strResult & "- Missing " & strBackupPath & "Pictures" & vbCrLf
        End If
    End If
    If blnVideos = True Then
        If ValidateFolder(strBackupPath & "Videos") = False Then
            strResult = strResult & "- Missing " & strBackupPath & "Videos" & vbCrLf
        End If
    End If

    ' Ensure Everything Validated
    If strResult <> "" Then
        objShell.Popup "An ERROR occurred backing up your files" & vbCrLf & _
            strResult & vbCrLf & _
            "Please contact " & strContact _
            , 30, "ERROR Backing Up Documents!", vbOkOnly + vbCritical
        Wscript.Quit
    End If

    ' Create Folder Pairs
    Call CreateSyncToyPairs(blnDocuments, strDocuments, blnMusic, strMusic, blnPictures, strPictures, blnVideos, strVideos)

    ' Run SyncToy Backup
    If blnDocuments = True Then
        Call RunSyncToy("Documents")
    End If
    If blnMusic = True Then
        Call RunSyncToy("Music")
    End If
    If blnPictures = True Then
        Call RunSyncToy("Pictures")
    End If
    If blnVideos = True Then
        Call RunSyncToy("Videos")
    End If

    ' Cleanup
    Set objFSO = Nothing
    Set objShell = Nothing

End Sub

Private Function ValidateFolder(ByVal strFolder)

    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim blnResult: blnResult = True
    On Error Resume Next
    If Not objFSO.FolderExists(strFolder) Then
        objFSO.CreateFolder(strFolder)
    End If
    If Err.Number <> 0 Then
        Err.Clear
        blnResult = False
    End If
    On Error Goto 0

    ValidateFolder = blnResult

End Function

Private Sub CreateSyncToyPairs(ByVal bDoc, ByVal sDoc, ByVal bMus, ByVal sMus, ByVal bPic, ByVal sPic, ByVal bVid, ByVal sVid)

    ' Create Objects
    Dim objShell: Set objShell = CreateObject( "WScript.Shell" )

    ' Attempt to Delete Folder Pairs
    Call DeleteSyncToyPair(sDoc,"Documents")
    Call DeleteSyncToyPair(sMus,"Music")
    Call deleteSyncToyPair(sPic,"Pictures")
    Call deleteSyncToyPair(sVid,"Videos")

    ' Create Folder Pairs
    If bDoc = True Then
        objShell.Run chr(34) & syncToyExe & Chr(34) & _
        " -d(left=" & chr(34) & sDoc & chr(34) & _
        ",right=" & chr(34) & strBackupPath & "Documents" & chr(34) & _
        ",name=Documents" & _
        ",operation=" & syncOperation & _
        ",excluded=*.jpg;*.jpeg;*.gif;*.bmp;*.png;*.mp3;*.m4a;*.mid;*.mpg;*.mpeg;*.divx;*.mov" & ")", 0, true  
    End If
    If bMus = True Then
        objShell.Run chr(34) & syncToyExe & Chr(34) & _
        " -d(left=" & chr(34) & sMus & chr(34) & _
        ",right=" & chr(34) & strBackupPath & "Music" & chr(34) & _
        ",name=Music" & _
        ",operation=" & syncOperation & _
        ",excluded=*.jpg;*.jpeg;*.gif;*.bmp;*.png;*.mp3;*.m4a;*.mid;*.mpg;*.mpeg;*.divx;*.mov" & ")", 0, true
    End If
    If bPic = True Then
        objShell.Run chr(34) & syncToyExe & Chr(34) & _
        " -d(left=" & chr(34) & sPic & chr(34) & _
        ",right=" & chr(34) & strBackupPath & "Pictures" & chr(34) & _
        ",name=Pictures" & _
        ",operation=" & syncOperation & _
        ",excluded=*.jpg;*.jpeg;*.gif;*.bmp;*.png;*.mp3;*.m4a;*.mid;*.mpg;*.mpeg;*.divx;*.mov" & ")", 0, true
    End If
    If bVid = True Then
        objShell.Run chr(34) & syncToyExe & Chr(34) & _
        " -d(left=" & chr(34) & sVid & chr(34) & _
        ",right=" & chr(34) & strBackupPath & "Videos" & chr(34) & _
        ",name=Videos" & _
        ",operation=" & syncOperation & _
        ",excluded=*.jpg;*.jpeg;*.gif;*.bmp;*.png;*.mp3;*.m4a;*.mid;*.mpg;*.mpeg;*.divx;*.mov" & ")", 0, true
    End If

    Set objShell = Nothing

End Sub

Private Sub DeleteSyncToyPair(ByVal strPath, ByVal strPair)

    ' Detect if a Config File Exists in the leftFolder and try to Delete Folder Pair
    ' This will ensure all Left Folder Files Write to the Right Folder and Will Skip
    ' Duplicates.  Otherwise Files on the left will not write to the right if they are
    ' deleted from the right
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objShell: Set objShell = CreateObject( "WScript.Shell" )
    Dim colFiles: Set colFiles = objFSO.GetFolder(strPath).Files
    Dim File, strErr
    For Each File in colFiles
        If InStr(1,File.Name,"SyncToy",1) > 0 AND StrComp(objFSO.GetExtensionName(File.Name),"dat",1) = 0 Then
            'SyncToy File Exists, Try to Delete Pair
            Call KillProcess("SyncToy.exe") 'Terminate SyncToy Processes Else a Delete Fails
            Call KillProcess("SyncToyCmd.exe")
            strErr = objShell.Run(chr(34) & syncToyExe & Chr(34) & " -u" & strPair, 0, false)
            'Cheap hack if it errors because the pair doesnt exist to kill the window
            Wscript.Sleep 10000
            Call KillProcess("SyncToy.exe")
            Call KillProcess("SyncToyCmd.exe")
        End If
    Next

    Set objFSO = Nothing
    Set objShell = Nothing

End Sub

Private Sub RunSyncToy(ByVal folderPair)

    ' Create Objects
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objShell: Set objShell = CreateObject( "WScript.Shell" )

    ' Run SyncToy as Manual or Automated
    If blnAutoRun = False Then
        objShell.Run chr(34) & syncToyExe & chr(34)
    Else
        ' Set Path to SyncToyLog and Clear Log
        Dim syncToyLog: syncToyLog = ExpandEnv("%LOCALAPPDATA%\Microsoft\SyncToy\2.0\SyncToyLog.log")
        If InStr(1,syncToyLog,"%",1) > 0 Then
            syncToyLog = ExpandEnv("%USERPROFILE%\Local Settings\Application Data\Microsoft\SyncToy\2.0\SyncToyLog.log")
        End If
        If InStr(1,syncToyLog,"%",1) > 0 Then
            syncToyLog = "!~ERROR~!"
        End If
        If objFSO.FileExists(syncToyLog) Then
            Call Logger(syncToyLog, "", True)
        End If 

        ' Run Automated SyncToy Backup
        objShell.Run chr(34) & syncToyCmdExe & Chr(34) & " -R " & chr(34) & folderPair & chr(34), 1, true

        ' Parse SyncToyLog to Ensure It Successfully Ran
        Dim strError: strError = ""
        If objFSO.FileExists(syncToyLog) Then
            strError = ParseSyncToyLog(syncToyLog)
            If strError <> "" Then
                ' Error Detected in Sync
                objShell.Popup "An ERROR occurred backing up folder pair: " & folderPair & vbCrLf & _
                strError & vbCrLf & _
                "Please contact " & strContact _
                , 30, "ERROR Backing Up Files!", vbOkOnly + vbCritical
            End If
        Else
            ' Error Getting Log to Parse
            objShell.Popup "An ERROR occurred obtaining log file to check for errors after backing up folder pair: " & folderPair & vbCrLf & _
            "Please contact " & strContact _
            , 30, "ERROR Backing Up Files!", vbOkOnly + vbCritical
        End If

        'Copy SyncToy Log to Backup Path
        If objFSO.FIleExists(syncToyLog) Then
            objFSO.CopyFile syncToyLog, strBackupPath, True
        End If
    End If

    ' Cleanup
    Set objFSO = Nothing
    Set objShell = Nothing

End Sub

Private Function ParseSyncToyLog(ByVal strLog)

    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Const ForReading = 1
    Dim objFile: Set objFile = objFSO.OpenTextFile(strLog, ForReading)
    Dim strLine
    Dim strResult: strResult = ""
    Dim blnAction: blnAction = True
    Dim blnWarning: blnWarning = False
    Dim blnError: blnError = False
    Do Until objFile.AtEndOfStream
        strLine = objFile.ReadLine
        If Len(strLine) > 0 Then
            ' Backup SyncToyLog for Archiving
            Call Logger(Replace(strLog,"SyncToyLog.log","SyncToyLog_Full.txt",1,1,1),strLine,False)

            ' Check If Actions Were Performed
            If InStr(1,strLine,"Found 0 actions to perform",1) > 0 Then
                blnAction = False
            End If

            ' Check If Warning Was Logged
            If InStr(1,strLine,"Warning:",1) > 0 Then
                blnWarning = True
                If strResult = "" Then
                    strResult = strLine
                Else
                    strResult = strResult & vbcrlf & strLine
                End If
            End If

            ' Check If Error Was Logged
            If InStr(1,strLine,"Error:",1) > 0 Then
                blnError = True
                If strResult = "" Then
                    strResult = strLine
                Else
                    strResult = strResult & vbcrlf & strLine
                End If
            End If
        End If
    Loop
    objFile.Close

    Set objFSO = Nothing

    ParseSyncToyLog = strResult

End Function

Private Sub KillProcess(ByVal strProcess)
    Dim strComputer: strComputer = "."
    Dim objWMIService: Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    Dim colItems: Set colItems = objWMIService.ExecQuery("Select * From Win32_Process")
    Dim objItem
    For Each objItem in colItems
        If StrComp(objItem.Name, strProcess, 1) = 0 Then
            objItem.Terminate()
        End If
    Next
End Sub

Private Function ExpandEnv(ByVal strPath)

    Dim objShell: Set objShell = CreateObject( "WScript.Shell" )
    ExpandEnv = objShell.ExpandEnvironmentStrings(strPath)
    Set objShell = Nothing

End Function

Private Sub Logger(fileName, logMessage, blnNewLog)

    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

End Sub

 

Oct 29

ChangePrimaryEmailDomain.vbs

Posted on by 
'=========================================================================
' ChangePrimaryEmailDomain.vbs
' VERSION: 1.1 - Corrected Case Sensitive Error When Matching SMTP
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 10/29/2012
' COMMENTS: Pass the ADsPath or Dinstinguished Name of the User/OU and New
' Email Domain to Modify the User(s) Primary SMTP Email Domain. The Script Will
' Grab the Local Part of the Users Current Primary Email, Append the New
' Domain to the End to Create the New Primary Email, and Make the Current Primay
' Email an Alias. It Will Also Update the Mail Attribute So the New Primary
' Email Displays On the General Tab of the Users Property in AD Users and Computers.
' Any Non-Email Enabled Users Will Be Skipped.
' EXAMPLE: Modify the User John Doe's Primary Email Domain (jdoe@domain.com -> jdoe@newdomain.com)
' Dim UserOrOU: UserOrOU = "CN=John Doe,CN=Users,DC=domain,DC=com"
' Dim NewDomain: NewDomain = "@newdomain"
' EXAMPLE: Modify All Users Primary Email Domain in an OU
' Dim UserOrOU: UserOrOU = "OU=Financial,DC=domain,DC=com"
' Dim NewDomain: NewDomain = "@newdomain.com"
'=========================================================================
Option Explicit
' ------ SCRIPT CONFIGURATION ------
Dim UserOrOU: UserOrOU = "OU=Financial,DC=domain,DC=com"
Dim NewDomain: NewDomain = "@newdomain.com"
' ------ END CONFIGURATION ------

Dim strLog: strLog = Replace(Wscript.ScriptName,".vbs",".txt")
Call ChangePrimaryEmailDomain(UserOrOU,NewDomain)
Wscript.Echo "Finished"

Private Function ChangePrimaryEmailDomain(strDN, strNewDomain)

On Error Resume Next

'Ensure We have a DN
strDN = Replace(strDN,"LDAP://","",1,1,1)

'Start Log File
Call Logger(strLog, "++++++++++++++++++++++++++++++++++++++++", True)
Call Logger(strLog, "+ " & Wscript.ScriptName, False)
Call Logger(strLog, "+ DN: " & strDN, False)
Call Logger(strLog, "+ New Domain: " & strNewDomain, False)
Call Logger(strLog, "++++++++++++++++++++++++++++++++++++++++" & vbCrLf & vbCrLf & vbCrLf, False)

'PutEx Constants
Const ADS_PROPERTY_CLEAR = 1
Const ADS_PROPERTY_UPDATE = 2
Const ADS_PROPERTY_APPEND = 3
Const ADS_PROPERTY_DELETE = 4

'Search AD
Const ADS_SCOPE_SUBTREE = 2
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
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
objCommand.CommandText = "SELECT AdsPath FROM 'LDAP://" & strDN & "' WHERE objectClass='user' AND objectCategory='person'"
Dim objRecordSet: Set objRecordSet = objCommand.Execute
Dim objUser, strEmail, strOldPrimary, strNewPrimary
Dim arrEmail()
Dim arrProxyAddresses
Dim i
Dim blnFound

' Process Results and List Emails
If objRecordSet.RecordCount < 1 Then
Call Logger(strLog, "Error No Records Found for DN", False)
Exit Function
End If
objRecordSet.MoveFirst
Do Until objRecordSet.EOF
Set objUser = GetObject(objRecordSet.Fields("AdsPath").Value)
Call Logger(strLog, vbCrLf & vbCrLf & "USER:" & objUser.AdsPath & vbCrLf & "=====================================================", False)
i = 0
'Build Array of Email Addresses and Get Primary SMTP
Call Logger(strLog, "Original Email Addresses" & vbCrLf & "------------------------------", False)
If Not IsArray(objUser.proxyAddresses) Then
'SKIP - Not Email Enabled
Call Logger(strLog, "SKIPPING - NOT EMAIL ENABLED", False)
Else
For Each strEmail in objUser.proxyAddresses
Call Logger(strLog, strEmail, False)
'Build Array of Email Addresses and Make All SMTP Addresses Lowercase
ReDim Preserve arrEmail(i)
If Left(strEmail,5) = "SMTP:" Then
strOldPrimary = "SMTP:" & LCase(Mid(strEmail,6))
arrEmail(i) = strOldPrimary
Elseif Left(strEmail,5) = "smtp:" Then
arrEmail(i) = "smtp:" & LCase(Mid(strEmail,6))
Else
arrEmail(i) = strEmail
End If
i = i + 1
Next

'Build New Primary SMTP (Assuming Local and Domain Are Lowercase From Above)
strNewPrimary = Left(strOldPrimary,InStr(1,strOldPrimary,"@",1)-1) & strNewDomain

'Modify Array(Assuming Local and Domain Are Lowercase From Above)
blnFound = False
For i = LBound(arrEmail) to UBound(arrEmail)
'Make the Old SMTP an Alias
If arrEmail(i) = strOldPrimary Then
arrEmail(i) = Replace(strOldPrimary,"SMTP:","smtp:",1,1,0)
End If

'New Primary SMTP is an Alias, Make it Primary
If arrEmail(i) = Replace(strNewPrimary,"SMTP:","smtp:",1,1,0) Then
blnFound = True
arrEmail(i) = strNewPrimary
End If
Next
If blnFound = False Then
'Add New Primary Email If It Didn't Exist
i = UBound(arrEmail) + 1
ReDim Preserve arrEmail(i)
arrEmail(i) = strNewPrimary
End If

'Log Modified Results
Call Logger(strLog, vbCrLf & "Modified Email Addresses" & vbCrLf & "------------------------------", False)
For i = LBound(arrEmail) to UBound(arrEmail)
Call Logger(strLog, arrEmail(i), False)
Next

'Write Results
objUser.PutEx ADS_PROPERTY_UPDATE, "proxyAddresses", arrEmail
objUser.SetInfo
Call Logger(strLog, "mail=" & Replace(strNewPrimary,"SMTP:","",1,1,1), False)
objUser.Put "mail", Replace(strNewPrimary,"SMTP:","",1,1,1)
objUser.SetInfo

If Err.Number <> 0 Then
Err.Clear
Call Logger(strLog, "RESULT: !~ERROR~!", False)
Else
Call Logger(strLog, "RESULT: SUCCESS", False)
End If

'Kill User Objects
Set objUser = Nothing
End If

objRecordSet.MoveNext

Loop

'Kill Search Objects
Set objConnection = Nothing
Set objCommand = Nothing

On Error Goto 0

End Function

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

 

Jan 01

EnumerateUsersByOU.vbs

Posted on by 
'=========================================================================
' EnumerateUsersByOU.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 1/1/2011
' COMMENTS: Pass the ADsPath or Dinstinguished Name of the Container/Organizational
' Unit to the Function, and it'll return all of the Users Within.
' EXAMPLE: strUserPath = "LDAP://CN=Users,DC=domain,DC=com"
'          strUserPath = "CN=Users,DC=domain,DC=com"
'=========================================================================
Option Explicit
' ------ SCRIPT CONFIGURATION ------
Dim strUserPath: strUserPath = "LDAP://CN=Users,DC=domain,DC=com"
' ------ END CONFIGURATION ------

Call Logger("EnumerateUsersByOU.txt", EnumerateUsersByOU(strUserPath), True)
Wscript.Echo "Finished"

Private Function EnumerateUsersByOU(userPath)

    On Error Resume Next

    userPath = Replace(userPath,"LDAP://","",1,1,1) 'Ensure DN not ADS Path
    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 FROM 'LDAP://" & userPath & "' WHERE objectCategory='person' AND objectClass='user'"
    Dim objRecordSet: Set objRecordSet = objCommand.Execute
    objRecordSet.MoveFirst
    Dim strResult: strResult = ""
    Do Until objRecordSet.EOF
        strResult = strResult & objRecordSet.Fields("AdsPath").Value & vbCrLf
        objRecordSet.MoveNext
    Loop

    EnumerateUsersByOU = strResult

    On Error Goto 0

End Function

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

 

Jan 01

ListUserForwardTo.vbs

Posted on by 
'=========================================================================
' ListUserForwardTo.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 1/1/2011
' COMMENTS: In AD the altRecipient Attribute aka Forward To, is the Email
' Address a User's Email Forwards to.
' Pass the ADsPath or Dinstinguised Name of the User or
' Container/Organizational Unit to the Function, Which Will List the
' User's ADsPath, User's Email, altRecipient User/Contact ADsPath, and the
' altRecipient Email.
' EXAMPLE: strUserPath = "LDAP://CN=Users,DC=domain,DC=com"
'          strUserPath = "CN=Users,DC=domain,DC=com"
'=========================================================================
Option Explicit
' ------ SCRIPT CONFIGURATION ------
Dim strUserPath: strUserPath = "LDAP://CN=Users,DC=domain,DC=com"
' ------ END CONFIGURATION ------
Call Logger("ListUserForwardTo.txt", "USER  USEREMAIL   ALTRECIPIENT    ALTRECIPIENTEMAIL   FWDCOPY", True)
Call Logger("ListUserForwardTo.txt", ListUserForwardTo(strUserPath), False)
Wscript.Echo "Finished"

Private Function ListUserForwardTo(userPath)

    On Error Resume Next

    userPath = Replace(userPath,"LDAP://","",1,1,1) 'Ensure DN not ADS Path
    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, mail, altRecipient, deliverAndRedirect FROM 'LDAP://" & userPath & "' WHERE objectCategory='person' AND objectClass='user'"
    Dim objRecordSet: Set objRecordSet = objCommand.Execute
    objRecordSet.MoveFirst
    Dim strResult: strResult = ""
    Dim objFwd
    Do Until objRecordSet.EOF
        If IsNull(objRecordSet.Fields("altRecipient").Value) Then
            strResult = strResult & objRecordSet.Fields("ADsPath").Value & vbTab & objRecordSet.Fields("mail").Value & vbTab & "N/A" & vbTab & "N/A" & vbCrLf
        Else
            Set objFwd = GetObject("LDAP://" & objRecordSet.Fields("altRecipient").Value)
            strResult = strResult & objRecordSet.Fields("ADsPath").Value & vbTab & objRecordSet.Fields("mail").Value & vbTab & "LDAP://" & objRecordSet.Fields("altRecipient").Value & vbTab & objFwd.mail & vbTab & "DeliverBoth:" & objRecordSet.Fields("deliverAndRedirect").Value & vbCrLf
            Set objFwd = Nothing
        End If
        objRecordSet.MoveNext
    Loop

    ListUserForwardTo = strResult

    On Error Goto 0

End Function

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

 

Jan 01

ModifyUserForwardTo.vbs

Posted on by 
'=========================================================================
' ModifyUserForwardTo.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 1/1/2011
' COMMENTS: In AD the altRecipient Attribute aka Forward To, is the Email
' Address a User's Email Forwards to.
'
' strUserPath: ADsPath or distinguishedName of the User You Want to Modify the
' Email Forwarding On. This can Also Be an Organization Unit/Container If You
' Want to Bulk Modify Users to Have Their Email Forwarded to the Same User/Contact.
'
' strFwdPath: ADsPath or distinguishedName of the User/Contact You Want Emails
' to Forward To.
'
' blnFwdCopy: This Value Must be True/False. True Delivers a Copy to Both The
' Forwarding Address and Keeps a Copy in the Mailbox. False Just Forwards the
' Email.
'
' The Function Will Return the Result, Users ADsPath, Whether the Forward Was
' Set to Send a Copy to Both, The New ForwardTo ADsPath, and Whether the Copy is
' Sent to Both User's ADsPath, User's Email, altRecipient User/Contact ADsPath, and the
' altRecipient Email.
' EXAMPLE: Modify Jim Smith To Forward Their Email to John Doe
'          strUserPath = "LDAP://CN=Jim Smith,CN=Users,DC=domain,DC=com"
'          strFwdPath = "LDAP://CN=John Doe,Users,DC=domain,DC=com"
'          blnFwdCopy = False
' EXAMPLE: Modify Jim Smith To Forward Their Email to John Doe and Keep a Copy In Jim's Mailbox
'          strUserPath = "LDAP://CN=Jim Smith,CN=Users,DC=domain,DC=com"
'          strFwdPath = "LDAP://CN=John Doe,Users,DC=domain,DC=com"
'          blnFwdCopy = False
' EXAMPLE: Bulk Modify Users to Forward Their Email to John Doe
'          strUserPath = "LDAP://CN=Users,DC=domain,DC=com"
'          strFwdPath = "LDAP://CN=John Doe,Users,DC=domain,DC=com"
'          blnFwdCopy = False
'=========================================================================
Option Explicit
' ------ SCRIPT CONFIGURATION ------
Dim strUserPath: strUserPath = "LDAP://CN=Jim Smith,CN=Users,DC=domain,DC=com"
Dim strFwdPath: strFwdPath = "LDAP://CN=John Doe,Users,DC=domain,DC=com"
Dim blnFwdCopy: blnFwdCopy = True
' ------ END CONFIGURATION ------

Call Logger("ModifyUserForwardTo.txt", "RESULT  USER    FWDTO   FWDCOPY NEWFWDTO    FWDCOPY", True)
Call Logger("ModifyUserForwardTo.txt", ModifyUserForwardTo(strUserPath,strFwdPath,blnFwdCopy), False)
Wscript.Echo "Finished It"

Private Function ModifyUserForwardTo(userPath, fwdPath, blnFwdCopy)

    On Error Resume Next

    userPath = Replace(userPath,"LDAP://","",1,1,1) 'Ensure DN not ADS Path
    fwdPath = Replace(fwdPath,"LDAP://","",1,1,1)   'Ensure DN not ADS Path
    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, altRecipient, deliverAndRedirect FROM 'LDAP://" & userPath & "'WHERE objectCategory='person' AND objectClass='user'"
    Dim objRecordSet: Set objRecordSet = objCommand.Execute
    objRecordSet.MoveFirst
    Dim strResult: strResult = ""
    Dim objUser, strTemp
    Do Until objRecordSet.EOF
        ' Log Original altRecipient Values
        If IsNull(objRecordSet.Fields("altRecipient").Value) Then
            strTemp = objRecordSet.Fields("ADsPath").Value & vbTab & "N/A" & vbTab & "N/A"
        Else
            strTemp = objRecordSet.Fields("ADsPath").Value & vbTab & objRecordSet.Fields("altRecipient").Value & vbTab & objRecordSet.Fields("deliverAndRedirect").Value
        End If

        ' Modify altRecipient Values
        Set objUser = GetObject(objRecordSet.Fields("ADsPath").Value)
        objUser.altRecipient = fwdPath
        If blnFwdCopy = True Then
            objUser.deliverAndRedirect = True
        End If
        strTemp = strTemp & vbTab & fwdPath & vbTab & blnFwdCopy
        objUser.SetInfo

        ' Error Check
        If Err.Number <> 0 Then
            Err.Clear
            strTemp = "!~ERROR~!" & vbTab & strTemp & vbCrLf
        Else
            strTemp = "SUCCESS" & vbTab & strTemp & vbCrLf
        End If
        strResult = strTemp
        objRecordSet.MoveNext
    Loop

    ModifyUserForwardTo = strResult

    On Error Goto 0

End Function

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