Add Logic That Invokes Outlook Macro For Future Events

A macro was written to send an " alert " email anytime an appointment was added to the Outlook Calendar AND is outside of normal business hours.

The macro works perfectly, but fires on any new appointment that is added to the Outlook calendar. This includes appointments that occurred in the past.

The macro needs to be modified to only send the alert, when the appointment start date time => (equal to or greater than) NOW.

A copy of the original macro has been included below:

Thanks in advance,
nss39759
Public WithEvents olkCalendar As Outlook.Items
 
Private Sub Application_Quit()
 
Set olkCalendar = Nothing
 
End Sub
 
Private Sub Application_Startup()
 
Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
 
End Sub
 
Private Sub olkCalendar_ItemAdd(ByVal Item As Object)
    Dim olkMsg As Outlook.MailItem, bolSendMsg As Boolean
    
'Change the category name as desired
If InStr(1, Item.Subject, "Call ") Then
    Item.Categories = "BUSINESS, Phone Calls"
    Item.Save
Else
    If InStr(1, Item.Categories, "Family") Or InStr(1, Item.Categories, "NCFPP") Or InStr(1, Item.Categories, "Phone Calls") Then
        'Nothing to do'
    Else
    Item.Categories = "BUSINESS"
        Select Case Weekday(Item.Start)
            Case vbSaturday, vbSunday
                bolSendMsg = True
            Case Else
                Select Case Hour(Item.Start)
                    Case 0 To 7
                        bolSendMsg = True
                    Case 17 To 23
                        bolSendMsg = True
                End Select
                If (Hour(Item.End) >= 17) Or (Hour(Item.End) < 8) Then bolSendMsg = True
        End Select
        If bolSendMsg Then
            Set olkMsg = Outlook.Application.CreateItem(olMailItem)
            With olkMsg
                .Recipients.Add "wife@work.com"
                .Recipients.Add "wife@home.com"
                .Recipients.Add "copy@me.com"
                .Recipients.ResolveAll
                .Subject = "After Hours Event Notification - " & Item.Subject
                .HTMLBody = "Hello My Love,<br><br>" _
                    & "I wanted to make you aware of an upcoming appointment on my calendar that's outside of regular working hours. Please let me know if this represents a conflict for anything you had planned. You may find details below:<br><br>" _
                    & "Title: " & Item.Subject & "<br>" _
                    & "Where: " & IIf(Item.Location = "", "Unspecified", Item.Location) & "<br>" _
                    & "Start: " & Item.Start & "<br>" _
                    & "End: " & Item.End & "<br><br>" _
                    & "Notes: <br>" & Item.Body & "<br><br>" _
                    & "Love,<br>" _
                    & "Me"
                .Send
            End With
        End If
    End If
    Set olkMsg = Nothing
End If
 
End Sub

Open in new window

nss39759Asked:
Who is Participating?
 
David LeeConnect With a Mentor Commented:
Hi, nss39759.

Replace the olkCalendar_ItemAdd subroutine with the one below.
Private Sub olkCalendar_ItemAdd(ByVal Item As Object)
    Dim olkMsg As Outlook.MailItem, bolSendMsg As Boolean
    'Change the category name as desired
    If InStr(1, Item.Subject, "Call ") Then
        Item.Categories = "BUSINESS, Phone Calls"
        Item.Save
    Else
        If InStr(1, Item.Categories, "Family") Or InStr(1, Item.Categories, "NCFPP") Or InStr(1, Item.Categories, "Phone Calls") Then
            'Nothing to do'
        Else
            If Item.Start > Now Then
                Item.Categories = "BUSINESS"
                Select Case Weekday(Item.Start)
                    Case vbSaturday, vbSunday
                        bolSendMsg = True
                    Case Else
                        Select Case Hour(Item.Start)
                            Case 0 To 7
                                bolSendMsg = True
                            Case 17 To 23
                                bolSendMsg = True
                        End Select
                        If (Hour(Item.End) >= 17) Or (Hour(Item.End) < 8) Then bolSendMsg = True
                End Select
                If bolSendMsg Then
                    Set olkMsg = Outlook.Application.CreateItem(olMailItem)
                    With olkMsg
                        .Recipients.Add "wife@work.com"
                        .Recipients.Add "wife@home.com"
                        .Recipients.Add "copy@me.com"
                        .Recipients.ResolveAll
                        .Subject = "After Hours Event Notification - " & Item.Subject
                        .HTMLBody = "Hello My Love,<br><br>" _
                            & "I wanted to make you aware of an upcoming appointment on my calendar that's outside of regular working hours. Please let me know if this represents a conflict for anything you had planned. You may find details below:<br><br>" _
                            & "Title: " & Item.Subject & "<br>" _
                            & "Where: " & IIf(Item.Location = "", "Unspecified", Item.Location) & "<br>" _
                            & "Start: " & Item.Start & "<br>" _
                            & "End: " & Item.End & "<br><br>" _
                            & "Notes: <br>" & Item.Body & "<br><br>" _
                            & "Love,<br>" _
                            & "Me"
                        .Send
                    End With
                End If
            End If
        End If
        Set olkMsg = Nothing
    End If
End Sub

Open in new window

0
 
nss39759Author Commented:
Good Day Blue Devil Fan,

So, I should just simply add the statement,

"If Item.Start > Now Then" and close it with 'End If"

Why not,

"If Item.Start => Now Then" ?

Regards,
nss39759
0
 
David LeeCommented:
Yes, that's the only change.  You change the test from greater than to greater than or equal to.  
0
 
Patrick MatthewsCommented:
0
 
David LeeCommented:
Hi, Patrick.

I'll have a look.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.