Option Explicit
Public Const CdoDefaultFolderCalendar = 0
Dim strSMTPServer, strMailFrom, strUserMailSubject, strUserMailBody
Dim strAdminMailRecip, strAdminMailSubject, strAdminMailBody
Dim strDefaultNamingContext, strQueryFilter, strAttName, strAttNote
Dim conn, com, iAdRootDSE, strNamingContext
Dim Rs, objGroup, strMember, objUser, strMsExchHomeServerName
Dim objSession, CdoInfoStore, CdoFolderRoot, ACLObj, CdoCalendar, FolderACEs, fldACE
Dim objRoot, objFreeBusyFolder
'Configuration parameters:
''''''''''''''''''''''''''''''''''''''''''''''
'Email notification configuration
strSMTPServer = "server.company.com" 'FQDN of SMTP server
strMailFrom = """Display Name"" <a href="mailto:SMTPAddress@company.com">SMTPAddress@company.com</a>" ' Display name and address of sender
strUserMailSubject = "The default permission on your calendar has been updated" 'Subject of message sent to users
strUserMailBody = "In order to promote effective collaboration among the Company " & _
"employees, the Default permission on your calendar has been updated to Reviewer. This allows anyone within the organization " & _
"to see the details of items within your calendar. For items that are of a sensitive, confidential, or personal nature, " & _
"you can mark them as Private. This will restrict the details of the item so that others cannot see the subject or body. " & _
"If you have any questions about this change, please reply to this message or contact the Help Desk at XXXX.<br><br>" & _
"Company Messaging and Collaboration Team (GAL Display Name)<br>Department<br>Company" 'Body of message sent to users
strAdminMailRecip = "<a href="mailto:SMTPAddress@company.com">SMTPAddress@company.com</a>" 'Address of admin to receive status report
strAdminMailSubject = "Default calendar permission change report" 'Subject of message sent to admin
'Domain to search for object
strDefaultNamingContext = "dc=company,dc=com" 'AD FQDN of base scope to search
'Search filter for group with users
strQueryFilter = "(&(objectcategory=group)(displayName=something))" 'LDAP filter to locate group with members to modify</p><p>'Attribute and notation for updated objects
strAttName = "extensionAttribute4" 'defined for a single-valued string attribute
strAttNote = "DefaultCalSet" 'Notation used to skip processed users on future script runs
''''''''''''''''''''''''''''''''''''''''''''''
strAdminMailBody = ""
Set conn = createobject("ADODB.Connection")
Set com = createobject("ADODB.Command")
Set iAdRootDSE = GetObject("<a href="ldap://RootDSE">LDAP://RootDSE</a>")
strNamingContext = iAdRootDSE.Get("configurationNamingContext")
Conn.Provider = "ADsDSOObject"
Conn.Open "ADs Provider"
Com.ActiveConnection = Conn
com.Properties("Page Size") = 1000
Com.CommandText = "<GC://" & strDefaultNamingContext & ">;" & StrQueryFilter & ";distinguishedname;subtree"
Set Rs = Com.Execute
While Not Rs.EOF
Set objGroup = GetObject("LDAP://" & Rs.fields("distinguishedname"))
For each strMember in objGroup.Member
Set objUser = GetObject("LDAP://" & strMember)
If InStr(objUser.Get(strAttName), strAttNote) < 1 Then
strAdminMailBody = strAdminMailBody & objUser.displayName & "<br>"
If objUser.Class = "user" And Not IsNull(objUser.msExchHomeServerName) And Not UCase(objUser.msExchHidefromAddressLists) = "TRUE" Then
strMsExchHomeServerName = objUser.msExchHomeServerName
strMsExchHomeServerName = right(strMsExchHomeServerName,len(strMsExchHomeServerName)-instrrev(strMsExchHomeServerName,"/cn=")-3)
strAdminMailBody = strAdminMailBody & "&nbsp;&nbsp;&nbsp;&nbsp;" & strMsExchHomeServerName & "<br>"
Call dofreebusy(strMsExchHomeServerName, objUser.mailNickname)
strAdminMailbody = strAdminMailBody & "&nbsp;&nbsp;&nbsp;&nbsp;Permission set on: " & objUser.mailNickname & "<br>"
WriteTag
SendEmail objUser.mail, strUserMailSubject, strUserMailBody
Else
strAdminMailBody = strAdminMailBody & "&nbsp;&nbsp;&nbsp;&nbsp;Skipping object<br>"
End If
End If
Next
Rs.MoveNext
Wend
Rs.Close
'Send admin email report
If Not strAdminMailBody = "" Then
strAdminMailBody = strAdminMailBody & "<br>Done.<br>"
Else
strAdminMailBody = "No mailboxes needed updating."
End If
SendEmail strAdminMailRecip, strAdminMailSubject, strAdminMailBody
Set conn = Nothing
Set com = Nothing
Function dofreebusy(serverName, mailboxName)
'Set Default permission to Reviewer
Set objSession = CreateObject("MAPI.Session")
objSession.Logon "","",false,true,0,true,servername & vbLF & mailboxname
Set CdoInfoStore = objSession.GetInfoStore
Set CdoFolderRoot = CdoInfoStore.RootFolder
Set ACLObj = CreateObject("MSExchange.aclobject")
Set CdoCalendar = objSession.GetDefaultFolder(CdoDefaultFolderCalendar)
ACLObj.CdoItem = CdoCalendar
Set FolderACEs = ACLObj.ACEs
For each fldACE in FolderACEs
If fldACE.ID = "ID_ACL_DEFAULT" Then
fldACE.Rights = 1025
ACLObj.Update
End If
Next
'Set local FreeBusy folder permission to Editor
Set objRoot = objSession.GetFolder("")
Set objFreeBusyFolder = objRoot.Folders.Item("FreeBusy Data")
ACLObj.CdoItem = objFreeBusyFolder
Set FolderACEs = ACLObj.ACEs
For each fldACE in FolderACEs
If fldACE.ID = "ID_ACL_DEFAULT" Then
fldACE.Rights = 1123
ACLObj.Update
End If
Next
End function
'Write notation tag into attribute
Sub WriteTag()
If IsNull(objUser.Get(strAttName)) or IsEmpty(objUser.Get(strAttName)) Then
objUser.Put strAttName, strAttNote & ";"
Else
Dim strExistAttName
strExistAttName = objUser.Get(strAttName)
objUser.Put strAttName, strExistAttName & strAttNote & ";"
End If
objUser.SetInfo
End Sub
'Send change notification and report
Sub SendEmail (strRecipAddress, strMailSubject, strMailBody)
Dim objMail
Set objMail = CreateObject("CDO.Message")
objMail.Configuration.Fields.Item ("<a href="http://schemas.microsoft.com/cdo/configuration/sendusing">http://schemas.microsoft.com/cdo/configuration/sendusing</a>") = 2
objMail.Configuration.Fields.Item ("<a href="http://schemas.microsoft.com/cdo/configuration/smtpserver">http://schemas.microsoft.com/cdo/configuration/smtpserver</a>") = strSMTPServer
objMail.Configuration.Fields.Item ("<span class="removed_link" title="http://schemas.microsoft.com/cdo/configuration/smtpserverport"></span>") = 25
objMail.Configuration.Fields.Update</p><p> objMail.From = strMailFrom
objMail.To = strRecipAddress
objMail.Subject = strMailSubject
objMail.HTMLBody = strMailBody
objMail.Send
Set objMail = Nothing
End Sub