'=========================================================================
' ModifyUserForwardTo.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: https://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
