Outlook VBS - Automatically delay sending evening & weekend emails until 0700 the following weekday (script not quite right)

[RichCowell]

Hi all,

I've got a script for Outlook that *should* delay sending emails Mon-Fri after 1800, and any time at the weekend, until 0700 the next weekday morning.

It seems to work Mon-Thu, but Fri-Sat it just sends it the following morning rather than waiting until Monday morning.

Can anyone help identify/correct the issues? I'm a complete novice with VBS & Outlook, but I'm trying to promote mental health and wellbeing, and trying to minimise the work I put on others outside working hours.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim dayname As String

' If after 6PM
  If Now() > DateSerial(Year(Now), Month(Now), Day(Now)) + #5:59:00 PM# Then
    sendat = DateSerial(Year(Now), Month(Now), Day(Now) + 1) + #7:00:00 AM#
' If before 7AM
  ElseIf Now() < DateSerial(Year(Now), Month(Now), Day(Now)) + #6:59:00 AM# Then
    sendat = DateSerial(Year(Now), Month(Now), Day(Now)) + #7:00:00 AM#
' We'll test the date of all messages
 ElseIf WeekdayName(Weekday(Now())) = "Saturday" Or WeekdayName(Weekday(Now())) = "Sunday" Then
   ' this will be changed by the next part if a weekend
   sendat = DateSerial(Year(Now), Month(Now), Day(Now)) + #11:00:00 PM#
 End If

dayname = WeekdayName(Weekday(sendat))

Select Case dayname
Case "Saturday"
    sendat = DateSerial(Year(Now), Month(Now), Day(Now) + 2) + #7:00:00 AM#
Case "Sunday"
    sendat = DateSerial(Year(Now), Month(Now), Day(Now) + 1) + #7:00:00 AM#
End Select
    Item.DeferredDeliveryTime = sendat
Debug.Print Now(), dayname, sendat

End Sub

Thanks,

Rick

 

[GWteB]

Currently when I run your code (5.53 PM CET) none of the conditions are met, so the sendat variable stays empty.
Therefore dayname results in "Sunday" because of the result of Weekday(0), although todays day is Monday.
So don't test on Saturday or Sunday in the last ElseIf clause, do test on Friday and ad a final Else clause where sendat obtains a valid date/time value.

Btw, this part in your code

DateSerial(Year(Now), Month(Now), Day(Now)

may be replaced with

Date

 

[GWteB]

.. and in the end it will look like this:

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

    Const DELAYDAYSFROM As String = "3.Friday, 2.Saturday, 1.Sunday"

    Dim AddDays As Long, Pos As Long, SendTime As Date

    ' assume a delayed send
    SendTime = #7:00:00 AM#

    ' assume monday, tuesday, wednesday or thursday
    If Time < #6:59:00 AM# Then
        AddDays = 0
    ElseIf Time > #5:59:00 PM# Then
        AddDays = 1
    Else
        ' send immediately
        AddDays = -1
    End If
   
    ' check on weekend
    Pos = InStr(1, DELAYDAYSFROM, VBA.Format$(Date, "dddd"), vbTextCompare)
    If Pos > 0 Then

        ' possible delay until monday
        AddDays = CLng(Mid$(DELAYDAYSFROM, Pos - 2, 1))
       
        ' Friday?
        If AddDays = 3 Then

            'Friday before 7.00 AM?
            If Time < #6:59:00 AM# Then
                ' yep, postpone to 7.00 AM same day
                AddDays = 0

            'Friday after 6.00 PM?
            ElseIf Time > #5:59:00 PM# Then
                ' yep, postpone to monday

            Else
                ' Friday during office hours, send immediately
                AddDays = -1
            End If
        End If
    End If

    If Not AddDays = -1 Then
        Item.DeferredDeliveryTime = Date + AddDays + SendTime
    End If
End Sub

 

[RichCowell]

Thanks for that @GWteB - that's quite a different code than the original - it's no wonder I couldn't work it out!
I'll get that tested over the next week... I'm planning on writing a blog post about it when I know it works - can I thank you and acknowledge @GWteB from mrexcel.com?

 

[GWteB]

You are welcome. I did not test it but I am quite sure it will work. If it doesn't work let me know, I'll keep watching ...

 

[RichCowell]

@GWteB - I've just had to remove the 32bit version off Office and install the 64bit (I'm using Office 365 bought through that rather than Office 2019 etc. - still the full client, but a different version)...
Do you know if there's likely to be a difference with that script in the 64bit version? Whenever I open Outlook now it gives me a warning about the Macro, and when I go to sign it again, it crashes Outlook completely without opening the Digital Signatures window...

 

[GWteB]

My code is just "plain" VBA. Afaik it should work on both 32 and 64-bit Office. I'm on 2013 32-bit and not able to test on 365 64-bit.
The warning you got may find it's cause in the current settings of Outlook's Trust Center which may have changed after the upgrade.
I don't use digital signatures so I can't tell whether Outlook argues about the current certificates (resulting in the crash you experienced) or not.
Pity I can't help you with your current issue. Perhaps another forum member who does have Outlook 365 64-bit is willing to step in ...

 

[RichCowell]

Thanks - I got to the bottom of it by deleting the VBA project, closing Outlook, deleting the OTM file in the %AppData%\Microsoft\Outlook folder, then doing it from scratch again... Looks like it's working again now...

 

[RichCowell]

Quick follow up... is it possible to add an exception/bypass to this based on a keyword e.g. putting "SendNow" in the subject (or snuck in the body - I could hide it in a tiny font then)?

 

[GWteB]

Okay, how about ...

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

    Const DELAYDAYSFROM As String = "3.Friday, 2.Saturday, 1.Sunday"
    Const KEYWORD       As String = "SendNow"                           ' <<<< change to suit

    Dim AddDays As Long, Pos As Long, SendTime As Date


    If InStr(1, Item.Body, KEYWORD, vbTextCompare) Then                 ' <<<< choise 1: keyword in body
'    If InStr(1, Item.Subject, KEYWORD, vbTextCompare) Then              ' <<<< choise 2: keyword in subject

        ' send immediately
        AddDays = -1

    Else

        ' assume a delayed send
        SendTime = #7:00:00 AM#
    
        ' assume monday, tuesday, wednesday or thursday
        If Time < #6:59:00 AM# Then
            AddDays = 0
        ElseIf Time > #5:59:00 PM# Then
            AddDays = 1
        Else
            ' send immediately
            AddDays = -1
        End If
       
        ' check on weekend
        Pos = InStr(1, DELAYDAYSFROM, VBA.Format$(Date, "dddd"), vbTextCompare)
        If Pos > 0 Then
    
            ' possible delay until monday
            AddDays = CLng(Mid$(DELAYDAYSFROM, Pos - 2, 1))
           
            ' Friday?
            If AddDays = 3 Then
    
                'Friday before 7.00 AM?
                If Time < #6:59:00 AM# Then
                    ' yep, postpone to 7.00 AM same day
                    AddDays = 0
    
                'Friday after 6.00 PM?
                ElseIf Time > #5:59:00 PM# Then
                    ' yep, postpone to monday
    
                Else
                    ' Friday during office hours, send immediately
                    AddDays = -1
                End If
            End If
        End If
    End If

    If Not AddDays = -1 Then
        Item.DeferredDeliveryTime = Date + AddDays + SendTime
    End If
End Sub