How to send follow up email if no response? - vba

Question

In the code below I don’t understand how the subroutine checks if the emails coming through are a reply of an email previously sent.
The first subroutine seems to check if the subject line of an incoming email matches this condition: "re: " & strSubject Or InStr(LCase(Item.Subject), strSubject)
After that I am confused. The only way the code works for me is by using categories. It does not work as shown below.
Public WithEvents objInboxItems As Outlook.Items
Private Sub Application_Startup()
Set objInboxItems = Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
'If receive the reply, clear the flag and remove the reminder
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
Dim objSentItems As Outlook.Items
Dim objVariant As Variant
Dim i As Long
Dim strSubject As String
Dim dSendTime As String
Set objSentItems = Outlook.Application.Session.GetDefaultFolder(olFolderSentMail).Items
If Item.Class = olMail Then
For i = 1 To objSentItems.Count
If objSentItems.Item(i).Class = olMail And **objSentItems.Item(i).categories = "Not Completed"** Then
Set objVariant = objSentItems.Item(i)
strSubject = LCase(objVariant.Subject)
dSendTime = objVariant.SentOn
If LCase(Item.Subject) = "re: " & strSubject Or InStr(LCase(Item.Subject), strSubject) > 0 Then
If Item.SentOn > dSendTime Then
With objVariant
.ClearTaskFlag
.ReminderSet = False
.Save
End With
End If
End If
End If
Next i
End If
End Sub
'Get a prompt asking if to send a notification email
Private Sub Application_Reminder(ByVal Item As Object)
Dim strPrompt As String
Dim nResponse As Integer
Dim objFollowUpMail As Outlook.MailItem
'You can change the subject as per your real case
If (Item.Class = olMail) And (LCase(Item.Subject) = "datanumen outlook repair") Then
strPrompt = "You haven't yet recieved the reply of " & Chr(34) & Item.Subject & Chr(34) & " within your expected time. Do you want to send a follow-up notification email?"
nResponse = MsgBox(strPrompt, vbYesNo + vbQuestion, "Confirm to Send a Follow-Up Notification Email")
If nResponse = vbYes Then
Set objFollowUpMail = Application.CreateItem(olMailItem)
With objFollowUpMail
.To = Item.Recipients.Item(1).Address
.Subject = "Follow Up: " & Chr(34) & Item.Subject & Chr(34)
.Body = "Please respond to my email " & Chr(34) & Item.Subject & Chr(34) & "as soon as possible"
.attachments.Add Item
.Display
End With
End If
End If
End Sub

Answer 1

The code just needs better commenting. The basic logic is: When a new email comes in, check if it's a reply to any email in the sent box. If so, remove the task and reminder flags from the sent email.
Public WithEvents objInboxItems As Outlook.Items
Private Sub Application_Startup()
Set objInboxItems = Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
'If receive the reply, clear the flag and remove the reminder
Private Sub objInboxItems_ItemAdd(ByVal Item As Object) 'New item received in inbox
Dim objSentItems As Outlook.Items
Dim objVariant As Variant
Dim i As Long
Dim strSubject As String
Dim dSendTime As String
' get all emails in sent box
Set objSentItems = Outlook.Application.Session.GetDefaultFolder(olFolderSentMail).Items
If Item.Class = olMail Then 'if new inbox item is email
For i = 1 To objSentItems.Count 'for each item in sent box
If objSentItems.Item(i).Class = olMail Then ' if sent item is email
Set objVariant = objSentItems.Item(i) 'sent email
strSubject = LCase(objVariant.Subject) 'sent email subject
dSendTime = objVariant.SentOn 'sent email send date
'Check subject, if new email is reply to sent email, or new email subject contains sent email subject
If LCase(Item.Subject) = "re: " & strSubject Or InStr(LCase(Item.Subject), strSubject) > 0 Then
If Item.SentOn > dSendTime Then ' if new email has later send date then sent email (else can't be reply)
With objVariant 'with sent email
.ClearTaskFlag ' clear flag
.ReminderSet = False 'remove reminder
.Save
End With
End If
End If
End If
Next i
End If
End Sub

Answer 2

The code listed above is badly written and wrong in general. The ItemAdd event is fired when an item is added to the folder, not received. For example, a user may move some items from one folder to another triggering this event. If you want to handle all incoming emails you need to handle the NewMailEx event of the Application class which is fired when a new message arrives in the Inbox and before client rule processing occurs. You can use the Entry ID returned in the EntryIDCollection array to call the NameSpace.GetItemFromID method and process the item. This event fires once for every received item that is processed by Microsoft Outlook. The item can be one of several different item types, for example, MailItem, MeetingItem, or SharingItem. The EntryIDsCollection string contains the Entry ID that corresponds to that item.
For i = 1 To objSentItems.Count 'for each item in sent box
If objSentItems.Item(i).Class = olMail Then ' if sent item is email
Instead of interating over all items in the folder and finding items that correspond to your conditions I'd recommend using the Find/FindNext or Restrict methods of the Items class. Read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder

Answer 3

I tried to recreate the situation, given flags are not reliable in my setup.
It may be possible to remove reminders by reinitializing ReminderTime.
Code for ThisOutlookSession
Option Explicit
Public WithEvents objInboxItems As Items
Private Sub Application_Startup()
Set objInboxItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub test_objInboxItems_ItemAdd()
' For testing select a reply to the flagged sent item
objInboxItems_ItemAdd ActiveExplorer.Selection(1)
End Sub
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
' If reply received,
' clear the flag and remove the reminder from the corresponding sent item
' No attempt to make the logic efficient
' - Find / Restrict in the sent items folder
' In my setup
' - TaskDueDate is always 4501-01-01 (no date)
' - Reminders on mailitems are not functional
Dim objSentItems As Items
Dim objVariant As Variant
Dim i As Long
Dim strSubject As String
Set objSentItems = Session.GetDefaultFolder(olFolderSentMail).Items
If Item.Class = olmail Then
Debug.Print
Debug.Print "Item.Subject ...........: " & Item.Subject
For i = 1 To objSentItems.Count
If objSentItems.Item(i).Class = olmail Then
Set objVariant = objSentItems.Item(i)
strSubject = LCase(objVariant.Subject)
If objVariant.ReminderTime <> "4501-01-01" Then
Debug.Print " strSubject ............: " & strSubject
Debug.Print " objVariant.SentOn .....: " & objVariant.SentOn
Debug.Print " objVariant.ReminderTime: " & objVariant.ReminderTime
If LCase(Item.Subject) = "re: " & strSubject Or InStr(LCase(Item.Subject), strSubject) > 0 Then
'Debug.Print " Item.SentOn .....: " & Item.SentOn
'Debug.Print " objVariant.SentOn: " & objVariant.SentOn
If Item.SentOn > objVariant.SentOn Then
Debug.Print " * strSubject ......: " & strSubject
Debug.Print " * Item.SentOn .....: " & Item.SentOn
Debug.Print " * objVariant.SentOn: " & objVariant.SentOn
If Now > objVariant.ReminderTime Then
With objVariant
' remove flag
.ClearTaskFlag
' attempt to remove reminder
.ReminderSet = False
' reinitializing ReminderTime may have an impact
.ReminderTime = "4501-01-01"
.Save
Debug.Print " ** Flag removed."
Debug.Print " ** Reminder removal attempted."
End With
End If
End If
Else
Debug.Print " *** subject does not match"
End If
End If
End If
Next i
End If
Debug.Print "done"
End Sub
Private Sub test_ToggleMarkAsTaskFlagAndSetReminder()
' for testing
' select a mailitem in the sent items folder to add a flag and a reminder
ToggleMarkAsTaskFlagAndSetReminder ActiveExplorer.Selection(1)
End Sub
Private Sub ToggleMarkAsTaskFlagAndSetReminder(ByVal objItem As Object)
' In my setup
' - TaskDueDate is always 4501-01-01 (no date)
' - Reminders on mailitems are not functional
If TypeOf objItem Is MailItem Then
Debug.Print
Debug.Print "objItem.Subject .............: " & objItem.Subject
Debug.Print " objItem.TaskDueDate Current: " & objItem.TaskDueDate
Debug.Print " objItem.ReminderTime Current: " & objItem.ReminderTime
' https://learn.microsoft.com/en-us/office/vba/api/outlook.olmarkinterval
If objItem.IsMarkedAsTask = False Then
objItem.MarkAsTask (olMarkThisWeek)
Debug.Print " * Marked as task"
' In my setup - TaskDueDate is always 4501-01-01
Debug.Print " objItem.TaskDueDate Updated?: " & objItem.TaskDueDate
Debug.Print " objItem.ReminderTime Updated?: " & objItem.ReminderTime
' In my setup - Reminders on mailitems are not functional
Debug.Print " objItem.ReminderSet Current: " & objItem.ReminderSet
objItem.ReminderSet = True
Debug.Print " objItem.ReminderSet Updated: " & objItem.ReminderSet
objItem.ReminderTime = DateAdd("d", -7, Now) ' testing
Debug.Print " objItem.ReminderTime Updated: " & objItem.ReminderTime
Else 'Reinitialize item
objItem.ClearTaskFlag
Debug.Print " * Task cleared"
' TaskDueDate not functional in my setup, remains 4501-01-01
Debug.Print " objItem.TaskDueDate Updated?: " & objItem.TaskDueDate
objItem.ReminderSet = False
Debug.Print " objItem.ReminderSet = False"
objItem.ReminderTime = "4501-01-01"
Debug.Print " objItem.ReminderTime Updated: " & objItem.ReminderTime
End If
'objItem.Display
objItem.Save
Else
Debug.Print "not a mailitem"
End If
End Sub