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
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
