FOUR ELMS BOOKKEEPING Mudford, Yeovil, Somerset  01935 850807

Outlook VBA macro example

Cleanse Outlook folders of unwanted emails

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 "j.bloggs@bloggs.com"
                           .Delete
                           
                        Case "a.smith@smith.co.uk"
                            .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 "j.bloggs@bloggs.com"
                    .Delete
                           
            Case "a.smith@smith.co.uk"
                   .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.