CJSmith dot me

I dump stuff I find useful here

Category: Outlook 2010

Outlook 2010: VBA delay sending of emails until the next working day if outside of reasonable hours

Published / by Chris Smith / Leave a Comment

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