VB Email Filters

Status
Not open for further replies.

Metronome

New Member
Outlook version
Outlook 2013 64 bit
Email Account
Office 365 Exchange
This is just a post to share code I'm already using - no bugs so far.

I rely heavily on rules and alerts in Outlook, and recently I ran into Microsoft's 256 kb limit on rules you can store in Outlook (wth?). To get around this, I designed custom email filtering code in VB using WithEvents. See below. I'm open to suggestions to improve this.

Code:
Private WithEvents insp As Outlook.Inspectors
'--------------------------------------------------------------------------------------------
' Create an event handler to handle items being added to the inbox. See link below:
'   https://msdn.microsoft.com/en-us/vba/outlook-vba/articles/using-events-with-automation
Private WithEvents Items As Outlook.Items
'
' Declare a public dictionary to load your email filtrs into (these can be defined directly
' in VB or loaded from a CSV or TXT file)
Public oSORT As Dictionary
'--------------------------------------------------------------------------------------------

Private Sub Application_Startup()
'--------------------------------------------------------------------------------------------
' Declare variables
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim sPATH As String
'--------------------------------------------------------------------------------------------


'--------------------------------------------------------------------------------------------
' If you're loading your email filters from a CSV file, create a filepath variable directing
' your code to the CSV. SortDict is a sub that loads two columns of CSV data into the public
' dictionary oSORT. It's important to load this on application startup and store as a public
' variable so the filters don't have to be reloaded every time a message is received.
'
' Define your items as the collection of inbox items and use the ItemAdd event to trigger
' your code when a new email is received.

    Set oSORT = CreateObject("Scripting.Dictionary")
    sPATH = "C:\Work\DDE\Tools\OutlookFilters.csv"
    Call SortDict(oSORT, sPATH)
    
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")

    Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
'--------------------------------------------------------------------------------------------
End Sub

Private Sub SortDict(ByRef oDICT As Dictionary, sPATH As String)
'--------------------------------------------------------------------------------------------
' This code takes an empty dictionary object and a csv file destination and loads the csv
' data into the dictionary. sPATH has to be the destination of a csv file including the
' filename, and the csv has to contain two columns of data.
    Dim sARR() As String
    
    Open sPATH For Input As #1
        Do Until EOF(1)
            Line Input #1, sVAR
            sARR() = Split(sVAR, ",")
            oDICT(sARR(0)) = sARR(1)
        Loop
    Close #1
'--------------------------------------------------------------------------------------------
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
    On Error GoTo ErrorHandler
    
'----------------------------------------------------------------------------------------------
' Declare variables
    Dim Msg As Outlook.MailItem
    Dim oNAMESPACE As Outlook.NameSpace
    Dim oFOLDER As Outlook.Folder
    Dim sVAR As String, sTO As String, sFROM As String
    Dim sARR() As String
    Dim recips As Outlook.Recipients
    Dim recip As Outlook.Recipient
    Dim i As Integer, k As Integer
'----------------------------------------------------------------------------------------------

    
'----------------------------------------------------------------------------------------------
' - Confirm Item is an email
' - Retrieve sender's email address
' - Determine if sender's address is in a predefined filter list
'   - Filter list is stored in a CSV file and read into a dictionary object. Left column of
'       CSV file is a list of email addresses. Right column contains destination subfolders
'       in the inbox. For multiple subfolder levels, each folder level must be specified and
'       separated by semicolons. For example: 'Vendors;Walmart;Order Confirmations'
' - If sender's address is stored in the predefined list, move the incoming message to the
'       destination folder
' - If sender's email isn't in filter list, iterate through recipients emails and perform
'       the same check
    If TypeName(Item) = "MailItem" Then
        Set Msg = Item
        Set oNAMESPACE = Application.GetNamespace("MAPI")
        Set oFOLDER = oNAMESPACE.GetDefaultFolder(olFolderInbox)

' This code is incomplete. The sender's address is stored differently depending on whether the incoming
' email came from an exchange user or not. Haven't run into any bugs so far but I expect to.
'        If Msg.SenderEmailType = "EX" Then
            sFROM = Msg.SenderEmailAddress
'        Else
'            Set pa = Msg.Sender.PropertyAccessor
'            sFROM = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E")
'        End If
        If oSORT.Exists(sFROM) Then
            If InStr(1, oSORT(sFROM), ";", vbTextCompare) Then
                sARR() = Split(oSORT(sFROM), ";")
                For i = LBound(sARR) To UBound(sARR)
                    Set oFOLDER = oFOLDER.Folders(sARR(i))
                Next i
            Else
                Set oFOLDER = oFOLDER.Folders(oSORT(sFROM))
            End If
            Msg.Move oFOLDER
            Set oFOLDER = Nothing
        Else
            Set recips = Msg.Recipients
            For Each recip In recips
                Set pa = recip.PropertyAccessor
                sTO = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E")
                If oSORT.Exists(sTO) Then
                    If InStr(1, oSORT(sTO), ";", vbTextCompare) Then
                        sARR() = Split(oSORT(sTO), ";")
                        For i = LBound(sARR) To UBound(sARR)
                            Set oFOLDER = oFOLDER.Folders(sARR(i))
                        Next i
                    Else
                        Set oFOLDER = oFOLDER.Folders(oSORT(sTO))
                    End If
                    Msg.Move oFOLDER
                    Set oFOLDER = Nothing
                    Exit For
                End If
            Next
        End If
    End If
'----------------------------------------------------------------------------------------------


'----------------------------------------------------------------------------------------------
' Error trapping and exit.
ProgramExit:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
'----------------------------------------------------------------------------------------------
End Sub
 
Microsoft's 256 kb limit on rules you can store in Outlook (wth?)
This is a limitation on Exchange server (it used to be even smaller!) POP3 and IMAP accounts shouldn't have a limit, although trying to manage too many rules in Outlook's rules wizard is not fun.
Exchange Server's Rules Limitation
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
S Create Outlook Task from Template and append Body with Email Body Outlook VBA and Custom Forms 4
H Copying email address(es) in body of email and pasting in To field Outlook VBA and Custom Forms 1
A Search folder and move the email Outlook VBA and Custom Forms 0
P VBA to add email address to Outlook 365 rule Outlook VBA and Custom Forms 0
farrissf Outlook 2016 Optimizing Email Searches in Outlook 2016: Seeking Insights on Quick Search vs Advanced Search Features Using Outlook 0
D Delete selected text in outgoing email body Outlook VBA and Custom Forms 0
F Graphics in email / Mac recipient garbled Using Outlook 0
D Outlook VBA forward the selected email to the original sender’s email ID (including the email used in TO, CC Field) from the email chain Outlook VBA and Custom Forms 3
Witzker Outlook 2019 Macro to seach in all contact Folders for marked Email Adress Outlook VBA and Custom Forms 1
E Outlook 365 Save Selected Email Message as .msg File - oMail.Delete not working when SEARCH Outlook VBA and Custom Forms 0
S Email Macros to go to a SHARED Outlook mailbox Draft folder...NOT my personal Outlook Draft folder Using Outlook 2
R Outlook 365 VBA AUTO SEND WITH DELAY FOR EACH EMAIL Outlook VBA and Custom Forms 0
G Print email attachments when hit subfolder Outlook VBA and Custom Forms 1
C Spam Email? Using Outlook 2
G Automatically delete email when a condition is met Outlook VBA and Custom Forms 1
E Save Selected Email Message as .msg File - digitally sign email doesn't works Outlook VBA and Custom Forms 1
S Email was migrated from GoDaddy to Microsoft exchange. We lost IMAP ability Exchange Server Administration 1
R Outlook 365 How to integrate a third-party app with Outlook to track email and sms? Using Outlook 2
S Paperclip icon shows without attachment in email under Sent folder Using Outlook 0
B Outlook 2019 Automatically move email after assigning category Using Outlook 4
Rupert Dragwater How to permanently remove an email address Using Outlook 9
K vba code to auto download email into a specific folder in local hard disk as and when any new email arrives in Inbox/subfolder Outlook VBA and Custom Forms 0
F Auto changing email subject line in bulk Using Outlook 2
F Want to add second email to Outlook for business use Using Outlook 4
kburrows Outlook Email Body Text Disappears/Overlaps, Folders Switch Around when You Hover, Excel Opens Randomly and Runs in the Background - Profile Corrupt? Using Outlook 0
J Outlook 365 Outlook Macro to Sort emails by column "Received" to view the latest email received Outlook VBA and Custom Forms 0
A Outlook 2019 Help with forwarding email without mentioning the previous email sender. Outlook VBA and Custom Forms 0
J Macro to send email as alias Outlook VBA and Custom Forms 0
M Shift Delete doesn't delete email from server Using Outlook 3
K Incorporate selection from combobox into body of email Outlook VBA and Custom Forms 0
L Why are some email automatically going to "archive" Using Outlook 2
M Outlook Macro to save as Email with a file name format : Date_Timestamp_Sender initial_Email subject Outlook VBA and Custom Forms 0
B Outlook 2019 Custom Email form - Edit default email form Outlook VBA and Custom Forms 6
F Add a category before "Send an Email When You Add an Appointment to Your Calendar" Outlook VBA and Custom Forms 0
T Problem when requesting to view an email in a browser Using Outlook 0
J Outlook 365 Forward Email Subject to my inbox when new email arrive in shared inbox Using Outlook 0
HarvMan Archive Email Manually Using Outlook 1
L Fetch, edit and forward an email with VBA outlook Outlook VBA and Custom Forms 2
S New Email "From" box stopped working Using Outlook 0
Rupert Dragwater Duplicate email in Folder Using Outlook 7
M "Attachment Detacher for Outlook" add in, does it update the server copy of the email? Using Outlook 1
W Outlook 365 I am getting the "Either there is no default mail client" error when I try to send an email on excel Office 365 Using Outlook 1
MattC Changing the font of an email with VBA Outlook VBA and Custom Forms 1
L Specific Incoming Email Address Immediately Deleted Using Outlook 2
Witzker Outlook 2019 Macro to send an Email Template from User Defined Contact Form Outlook VBA and Custom Forms 0
Witzker Outlook 2019 Edit contact from email does not open the user defined contactform Using Outlook 3
V Macro to mark email with a Category Outlook VBA and Custom Forms 4
R Roadrunner Email Settings | Contact Roadrunner Customer Support Outlook VBA and Custom Forms 0
D Gmail mail is being delivered to a different email inbox in Outlook App 2021 Using Outlook 2
Albert McCann Outlook 2021 Outlook Display of HTML Email from two senders is glitchy Using Outlook 0

Similar threads

Back
Top