Our IT Leadership team decided that it will promote more effective collaboration if the Default calendar permission for all IT employees is set to Reviewer (instead of the Default of None). As with many of my scripts, I started with the work Glen Scales has already done. Go there for information on the prerequisite for using this script to make the change (the need for ACL.dll).
Glen’s script uses an input argument of a server name. My distributed environment doesn’t allow for such a broad application, so I use the membership of a DL that contains the IT personnel. This DL actually contains other DLs, so I separately use another script by Richard Mueller that enumerates nested groups and puts the results into a domain local group that is used for other purposes.
After getting the group members, I loop through each member for only those with a mailbox that isn’t hidden. For those who haven’t been touched by the script before, a function is called that uses CDO to log into the mailbox, enumerate the calendar permissions looking for the Default entry, and change it to Reviewer. The user’s local FreeBusy Data folder is also updated to set the Default to Editor since that permission goes hand in hand when setting permissions on the calendar.
To keep tabs on who the script has touched, a notation is added to extensionAttribute4 (customizable). Those with that notation are skipped in the future. Then an email is sent to the user informing them of the change. I chose to do this because Exchange users may be used to the fact the the Default permission is None; this way they are aware that their calendar is open for viewing. It also helps with new employees who are not aware of this "policy" and can mark items as Private as necessary.
Finally, an email is sent to the admin with the results of the job run. It includes the display name, mailbox server, and whether the permission was set or the object skipped (to catch entries that slip through my filter). I have scheduled this to run weekly, and I will get an email each time so I know that the script is successfully running and which users are being modified.
All of the variables that require customization are near the top. These are for mail configuration, search filter, and the notation parameters for touched mailboxes.
Download it here or copy below.
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
'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 & " " & strMsExchHomeServerName & "<br>"
Call dofreebusy(strMsExchHomeServerName, objUser.mailNickname)
strAdminMailbody = strAdminMailBody & " Permission set on: " & objUser.mailNickname & "<br>"
WriteTag
SendEmail objUser.mail, strUserMailSubject, strUserMailBody
Else
strAdminMailBody = strAdminMailBody & " 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 ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTPServer
objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMail.Configuration.Fields.Update
objMail.From = strMailFrom
objMail.To = strRecipAddress
objMail.Subject = strMailSubject
objMail.HTMLBody = strMailBody
objMail.Send
Set objMail = Nothing
End Sub
Comments (0) 
Themocracy