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.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 |
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 |
Receiving a strange error running this script:
Line 48
Char 1
Table does not exist.
Line 48 begins the for loop for each member in the group. “Table does not exist” sounds like your array objGroup.Member is null. How many people are in the group you are testing it with? If it is just one, the attribute won’t be an array, but a string value. Try adding someone else to the group so that it becomes an array.