FOUR ELMS BOOKKEEPING
Mudford, Yeovil, Somerset
This code will delete emails sent to you from email addresses you specify and from any Outlook folders you choose provided they were sent over 21 days ago. If you have been sent weekly or monthly emails from the same sender for the past few years this macro can conveniently delete all the old emails in one go. The code will not, however, delete emails that you sent yourself and which are recorded in any Outlook 'Sent Items' folders. If you wish, the following code can be copied and pasted into your Visual Basic editor which is found under the Micrsoft Outlook Developer tab. (You may have to load this tab in your Outlook setup). You will need to enter a list of sender email addresses in the code where shown following the syntax of the two examples given. This code is able to delete open emails as well as filtering and deleting selected emails from an entire Outlook folder. To sift through all the emails in an Outlook folder and delete selected ones call the SearchAndRemove macro. If you have an individual email open in Outlook you can delete it by calling the GetAddressEntry macro. These macros can be linked to toolbar icons in the Outlook application and individual emails respectively to allow one click operation.
'Declare Variables shared by more than one of the sub procedures below Dim CalledFromErrorHandler As Boolean 'set by SearchAndRemove errorhandler, used in GetSenderAddressEntry Dim AddressOfSender As String 'used by SearchAndRemove and value set by GetSenderAddressEntry Sub SearchAndRemove() 'THIS CODE SEARCHES THROUGH ALL EMAILS IN THE CURRENTLY OPEN OUTLOOK FOLDER 'and deletes any that are from one of the unwanted senders Dim NumEmailsInFolder, LoopNum As Integer 'used for the iteration loop Dim DeletedEmails As Integer 'tally of emails deleted 'Reset shared variable to default value (only becomes TRUE if errorhandler2 is triggered) CalledFromErrorHandler = False 'prevent deletion from Sent Items folders If Outlook.Application.ActiveExplorer.CurrentFolder.Name = "Sent Items" Then ans10 = MsgBox("To prevent loss of important emails deletion is not permitted from Sent Items folders", vbOKOnly + vbInformation, "No deletion from Sent Items folders") Exit Sub End If 'display the email address and folder name before deletions ans = MsgBox("Folder to be cleansed is: " + Replace(Outlook.Application.ActiveExplorer.CurrentFolder.FolderPath, "\\", Empty) + ". Is this correct?", vbYesNo + vbInformation, "Check Outlook Folder") If ans = vbNo Then ans1 = MsgBox("Mailbox Cleaner program is terminating", vbOKOnly, "Program Ending") Else 'determine the number of items in the folder in order to set up a loop NumEmailsInFolder = Outlook.Application.ActiveExplorer.CurrentFolder.Items.Count If NumEmailsInFolder > 1 Or NumEmailsInFolder = 0 Then ans2 = MsgBox("There are " + Str(NumEmailsInFolder) + " emails in this folder.", vbOKOnly + vbInformation, "Items in the folder") Else ans2 = MsgBox("There is " + Str(NumEmailsInFolder) + " email in this folder.", vbOKOnly + vbInformation, "Items in the folder") End If For LoopNum = 1 To NumEmailsInFolder On Error GoTo ErrorHandler With Outlook.Application.ActiveExplorer.CurrentFolder.Items(LoopNum) On Error GoTo 0 On Error GoTo ErrorHandler2 'set the rule that deleted items must be over 3 weeks old If DateValue(.SentOn) < DateAdd("d", -21, Date) Then 'for economy of code assume email is to deleted LoopNum = LoopNum - 1 'index of email is from bottom of list upwards 'inspect the sender's email address to determine if the email 'is to be deleted or not AddressOfSender = Outlook.Application.ActiveExplorer.CurrentFolder.Items(LoopNum + 1).SenderEmailAddress 'Check email address against list of email addresses to delete Select Case AddressOfSender 'LIST THE EMAIL ADDRESSES OF SENDERS OF EMAILS YOU WANT TO DELETE HERE, 'PRECEDED BY 'Case' AND FOLLOWED BY THE '.Delete' command ON THE FOLLOWING LINE. 'ENCLOSE EACH EMAIL ADDRESS IN QUOTES. Case "firstname.lastname@example.org" .Delete Case "email@example.com" .Delete Case Else 'reverse decrement of iteration index LoopNum = LoopNum + 1 End Select On Error GoTo 0 End If End With If LoopNum >= Outlook.Application.ActiveExplorer.CurrentFolder.Items.Count Then Exit For Next DeletedEmails = NumEmailsInFolder - Outlook.Application.ActiveExplorer.CurrentFolder.Items.Count ans3 = MsgBox(Str(DeletedEmails) + " emails were deleted from the folder " + Outlook.Application.ActiveExplorer.CurrentFolder.Name + ".", vbOKOnly + vbInformation, "Tally of deleted emails") End If Exit Sub ErrorHandler: 'this error handler caters for error where procedure cannot find the email with 'the specified index 'LoopNum'. In this case the index is incremented by one. LoopNum = LoopNum + 1 Resume ErrorHandler2: 'this error will arise from failure to extract the email address from the email 'by using the simple method. Use the Property Accessor instead CalledFromErrorHandler = True 'shared variable GetAddressEntry 'this will reextract the email address of the sender CalledFromErrorHandler = False 'return to default value Resume Next End Sub Sub GetAddressEntry() Dim oMail As MailItem Set oMail = Application.ActiveInspector.CurrentItem GetSenderAddressEntry oMail End Sub 'THIS CODE (called by introductory code above) deletes the CURRENTLY OPEN 'email if it is from one of the unwanted senders Sub GetSenderAddressEntry(ByVal oM As MailItem) Dim oPA As Outlook.PropertyAccessor Dim oContact As Outlook.ContactItem Dim oSender As Outlook.AddressEntry Dim SenderID As String Dim mail As Outlook.MailItem Set mail = Application.ActiveInspector.CurrentItem 'Create an instance of PropertyAccessor Set oPA = oM.PropertyAccessor 'Obtain PidTagSenderEntryId and convert to string SenderID = oPA.BinaryToString _ (oPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C190102")) 'Obtain AddressEntry Object of the sender Set oSender = Application.Session.GetAddressEntryFromID(SenderID) If CalledFromErrorHandler <> True Then With mail Select Case oSender.Address 'COPY THE LIST OF THE EMAIL ADDRESSES OF SENDERS OF EMAILS YOU WANT TO DELETE HERE, 'FOLLOWED BY THE '.Delete' command Case "firstname.lastname@example.org" .Delete Case "email@example.com" .Delete Case Else ans = MsgBox("This email has not come from one of the senders whose emails you want to automatically delete.", vbOKOnly + vbInformation, "Email will not be deleted") End Select End With Else 'if call to this procedure originated with the folder cleansing 'SearchAndRemove' 'above, then we just want to extract the email address of the sender by this alternative 'method using the PropertyAccessor, then resume the procedure. AddressOfSender = oSender.Address End If End Sub
Be aware that if you use this macro to delete emails from 'Inbox', 'Outbox', 'Drafts', or 'Search Folder' folders then the emails will be merely transferred to a 'Deleted Items' folder. If you use the macro to delete emails from a 'Deleted Items' folder then these emails are permanently deleted from Outlook. Unlike most manual changes, deletions performed by this macro cannot be undone using the Undo toolbar button.
Proprietor: Richard Waggett B.Sc., Ph.D., MICB, CBDip.,Dip.PM