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
