The first 4 items below help cleanup emails that have been categorized as "timeout" emails sent from our web server.
Below, the Application_Reminder event handler will fire whenever a reminder occur.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim olNs As Outlook.NameSpace
Set olApp = Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Items = olNs.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
'Debug.Print CStr(Now) & ": START: Items_ItemAdd"
On Error GoTo ErrorHandler
If TypeName(Item) = "MailItem" Then
MoveTimeoutsFromInbox
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & ": " & Err.Description
Resume ProgramExit
End Sub
Public Sub MoveTimeoutsFromInbox()
'Dim DeletedItemsFolder As Outlook.MAPIFolder
Dim olNs As Outlook.NameSpace
Dim Item As Object
Dim InboxItems As Outlook.Items
Dim MyMailItem As Outlook.MailItem
Dim counter As Long
Dim position As Integer
Dim DateAWeekAgo As Date
On Error GoTo ErrorInfo
Set olNs = Application.GetNamespace("MAPI")
'Set DeletedItemsFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
Set InboxItems = olNs.GetDefaultFolder(olFolderInbox).Items
DateAWeekAgo = DateAdd("d", -7, Now())
' Loop through the Items in the folder backwards (most recent first)
For counter = InboxItems.Count To 1 Step -1
Set Item = InboxItems(counter)
If Item.Class = olMail Then
Set MyMailItem = Item
If MyMailItem.SentOn < DateAWeekAgo Then
Exit Sub ' If the email was sent over a week ago, stop processing because we've reached a week of emails
End If
' If there is a category and the email was sent more than 75 minutes ago, move it to NoReply if it has Timeout category
If MyMailItem.Categories <> "" Then
Debug.Print CStr(Now) & ": MoveTimeoutsFromInbox: Mail has categories"
position = InStr(MyMailItem.Categories, "Timeout")
If position > 0 Then
Debug.Print "Timeout found. Minutes past since sent: " & CStr(DateDiff("n", MyMailItem.SentOn, Now()))
If MyMailItem.SentOn < DateAdd("n", -75, Now()) Then
Item.Move olNs.GetDefaultFolder(olFolderDeletedItems).Folders("NoReply")
Debug.Print "Timeout moved."
End If
End If
End If
End If
Next counter
ProgramExit:
Set olNs = Nothing
Set Item = Nothing
Set InboxItems = Nothing
Exit Sub
ErrorInfo:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume ProgramExit
End Sub
Public Sub Application_Reminder(ByVal Item As Object)
If TypeOf Item Is Outlook.TaskItem Then
Dim ReminderSubject As String
Dim olTask As Outlook.TaskItem
Set olTask = Item
ReminderSubject = "Run Rule: noreply to Deleted Items - NoReply"
'Run Rule: noreply to Deleted Items - NoReply
Dim objRules As Outlook.Rules
Set objRules = Outlook.Application.Session.DefaultStore.GetRules
' Refer to the subject of the specific task item
If olTask.Subject = ReminderSubject Then
' The corresponding specific rule
Dim objRule As Outlook.Rule
Set objRule = objRules.Item("noreply to Deleted Items - NoReply")
objRule.Execute ShowProgress:=True, Folder:=Session.GetDefaultFolder(olFolderDeletedItems), IncludeSubfolders:=False
Set objRule = Nothing
'MsgBox ("Deleted NoReply emails moved successfully")
End If
Set objRules = Nothing
If LCase$(olTask.Subject) = LCase$(ReminderSubject) Then
' Set next reminder - "Snooze" for 5 hours
olTask.ReminderTime = DateAdd("h", 5, olTask.ReminderTime)
olTask.Save
End If
Set olTask = Nothing
End If
End Sub
