VBA – Auto Delete Emails After ‘X’ Days

Stewy_123

New Member
Joined
Jul 19, 2021
Messages
2
Office Version
  1. 2016
Platform
  1. Windows
Hi all,
Back Ground: Due to the nature of my business I receive a vast amount of emails, many of which I have archiving rules to store in designated folders. A good amount of the emails I would like to retain and some I would like to delete after x days. Here I will highlight that my IT Dept are reluctant to turn on the ‘AutoArchiving’ feature within MS Outlook due to outdated retention policies (I am sure many of you have also faced similar difficulties). Thus, I have identified the below code which works by searching for an email address within the default ‘Inbox’ and deletes after x days. For some reason the code breaks down when attempting to add an additional email addresses within the search function lines (no doubt I am missing something simple here). Wondering if anyone would know how to add multiple email address to the search and delete rule?

Best
Stu
(Code Below using John.Smith@xxx.com as example email address)


Public WithEvents objInboxItems As Outlook.Items


Private Sub Application_Startup()

'Dim objInboxItems As Outlook.Folder


Set objInboxItems = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items

Call DeleteEmailsFromStuartAfterXDays

End Sub


Private Sub objInboxItems_ItemAdd(ByVal Item As Object)

Dim objMail As Outlook.MailItem

If TypeOf Item Is MailItem Then

Set objMail = Item

'From the specific sender

If objMail.SenderEmailAddress = "John.Smith@xxx.com" Then

'Set expiry time - after 1 days

objMail.ExpiryTime = objMail.ReceivedTime + 0

objMail.Save

End If

End If

End Sub


Private Sub DeleteEmailsFromStuartAfterXDays()

Dim strFilter As String

Dim objExpiredItems As Outlook.Items

Dim objExpiredMail As Outlook.MailItem

strFilter = "[ExpiryTime] <= " & Chr(34) & Now & Chr(34)

'Get all expired items

Set objExpiredItems = objInboxItems.Restrict(strFilter)


For i = objExpiredItems.Count To 1 Step -1

If objExpiredItems(i).Class = olMail Then

Set objExpiredMail = objExpiredItems(i)


'Auto delete expired emails from the specific sender

If objExpiredMail.SenderEmailAddress = "John.Smith@xxx.com" Then

objExpiredMail.Delete

End If

End If

Next

Set objExpiredItems = Nothing

End Sub
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.

Forum statistics

Threads
1,223,243
Messages
6,170,964
Members
452,371
Latest member
Frana

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top