This Outlook 2010 VBA code was used to impose a time when emails could not be sent and were instead delayed until the next work day.
This was put together (Credits go to key parts of this VBA are in the actual code) because the Managing Director where I work realised he was making people work outside of their core hours.
The script however will send emails if the email is set to high priority or if a user is in the email group “Send_at_all_times”.
Restrictions include having to sign the code (Otherwise Outlook VBA security has to be lowered), the other is since the code doesnt do anything fancy it will always send if someone it sends to is in the group “Send_at_all_times”.
- This has only been tested in Microsoft Outlook 2010 on Windows 7.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) On Error GoTo Err_Application_ItemSend 'Credits for core script is https://www.mikesel.info/delay-outlook-mail-sending/ 'and http://www.vbforums.com/showthread.php?574491-RESOLVED-Outlook-VB-Macro-Deffered-Delivery-Time 'Credits for dist group grab is http://blogs.technet.com/b/heyscriptingguy/archive/2007/03/27/how-can-i-list-all-the-members-of-a-microsoft-outlook-distribution-list.aspx 'This script is to delay emails until the next working day if outside of reasonable hours. The script can be bypassed by sending emails with the importance level of HIGH 'There is also a group lookup to also always send if in this group. Dim obj As Object Dim Mail As Outlook.MailItem Dim WkDay, SendNow, SendtoAddress As String Dim MinNow, SendHour As Integer Dim SendDate As Date Dim emailItem As Outlook.MailItem Dim objOutlook, objNamespace, objDistList, colContacts As Object Dim i, j, intCount As Integer Dim groupaddresses() As String 'Grab list of contacts from Dist Group, done after importance check as important emails don't require this check anyway Const olFolderContacts = 10 Set objOutlook = CreateObject("Outlook.Application") Set objNamespace = objOutlook.GetNamespace("MAPI") Set colContacts = objNamespace.GetDefaultFolder(olFolderContacts).Items 'Grab email address being sent to Set emailItem = Application.ActiveInspector.CurrentItem SendtoAddress = emailItem.To 'MsgBox colContacts.Count & SendtoAddress 'Grab amount of users in email group and redim array Set objDistList = colContacts.Item("Send_at_all_times") ReDim groupaddresses(objDistList.MemberCount) SendNow = "N" 'Added a limit of intCount users to try and prevent any unexpected looping issues i = 1 For j = 1 To objDistList.MemberCount groupaddresses(j) = objDistList.GetMember(j).Name 'If address does not match anything in group address run code below otherwise skip If InStr(1, SendtoAddress, groupaddresses(j), 1) = 0 Then 'Should never happen but just in case trap going over member count to prevent an endless loop! If i <= objDistList.MemberCount Then i = i + 1 Else 'This error should never occur!! Bail out of For loop to prevent endless loop. MsgBox "Failed! More than " & objDistList.MemberCount & "users are in this group" Exit For End If Else 'Set SendNow to Yes as a match was found SendNow = "Y" Exit For End If Next 'Check if email is set to Normal or low importance 'Our requirement is for anything set to important to always send immediately, if not required comment out the if statement and the associated end if If emailItem.Importance <> olImportanceHigh And SendNow = "N" Then 'Code to check whether email needs to be delayed 'Set Variables SendDate = Now() SendHour = Hour(Now) MinNow = Minute(Now) WkDay = Weekday(Now) SendNow = "Y" 'Check if Before 8am If SendHour < 8 Then SendHour = 8 - SendHour SendDate = DateAdd("h", SendHour, SendDate) SendDate = DateAdd("n", -MinNow, SendDate) SendNow = "N" End If 'Check if after on or after 7PM If SendHour >= 19 Then 'After 7 PM amended to >= SendHour = 32 - SendHour 'Send a 8 am next day SendDate = DateAdd("h", SendHour, SendDate) SendDate = DateAdd("n", -MinNow, SendDate) SendNow = "N" End If 'Check if Sunday If WkDay = 1 Then SendHour = 8 - SendHour SendDate = DateAdd("d", 1, SendDate) SendDate = DateAdd("h", SendHour, SendDate) SendDate = DateAdd("n", -MinNow, SendDate) SendNow = "N" End If 'Check if Saturday If WkDay = 7 Then SendHour = 8 - SendHour SendDate = DateAdd("d", 2, SendDate) SendDate = DateAdd("h", SendHour, SendDate) SendDate = DateAdd("n", -MinNow, SendDate) SendNow = "N" End If 'Send the Email or Queue it if variable SendNow = N Set obj = Application.ActiveInspector.CurrentItem If TypeOf obj Is Outlook.MailItem Then Set Mail = obj 'Check if we need to delay delivery If SendNow = "N" Then Mail.DeferredDeliveryTime = SendDate End If 'Mail.Send End If 'End if for date checks Else End If Err_Application_ItemSend_Exit: 'Destroy Variables Exit Sub Err_Application_ItemSend: 'MsgBox Error$ Resume Err_Application_ItemSend_Exit End Sub