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

Select allOpen in new window