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
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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
J Outlook 2019 Regex email addresses from body Outlook VBA and Custom Forms 2
D Prompt to prefix subject line whenever sending an email Outlook VBA and Custom Forms 3
J Quick steps delete original email and move reply/sent email to folder Using Outlook 2
C Wishlist Extract or scan new email addresses from out of office replies. Leads from OOO replies Using Outlook 1
T External email warning banner Outlook VBA and Custom Forms 0
A Links in email getting error message about group policy Using Outlook 4
richardwing Auto forward email that is moves into a specific outlook folder Outlook VBA and Custom Forms 5
J Recommendations for Outlook Duplicate Email Remover Using Outlook 6
Geldner Tweak Junk Email Reporting tool to default to particular email on send? Using Outlook 3
S Outlook 365 Can I change the possible range of highlighting colours when writing an Outlook email? Using Outlook 1
V Can one change the formatting of email title blocks? Using Outlook 0
P default font when sending email from browser Using Outlook 1
D VBA Macro to Print and Save email to network location Outlook VBA and Custom Forms 1
B IMAP server rejects sent email - cannot deliver messages Using Outlook 2
TedSch Small vba to kill political email Outlook VBA and Custom Forms 3
X Open Hyperlinks in an Outlook Email Message (Help with Diane's solution) Outlook VBA and Custom Forms 3
e_a_g_l_e_p_i Email notifications changed with Outlook 2021 Using Outlook 8
glnz How to retrieve or redo Verizon.net email password without affecting Outlook connection? Using Outlook 1
Z Copy specific email body text Outlook VBA and Custom Forms 0
D ISOmacro to extract active mail senders name and email, CC, Subject line, and filename of attachments and import them into premade excel spread sheet Outlook VBA and Custom Forms 2
M Outlook 365 refuses to send email Using Outlook 1
B Search and Find Email by Folder Name Outlook VBA and Custom Forms 2
K Closing external IMAP email... Outlook 2013 Using Outlook 0
L Capture email addresses and create a comma separated list Outlook VBA and Custom Forms 5
C Email bomb processing Outlook VBA and Custom Forms 1
O What would be the recommended way to change an email address (family member)? Using Outlook 0
A Outlook 2016 Macro to Reply, ReplyAll, or Forward(but with composing new email) Outlook VBA and Custom Forms 0
L Checking Sender Email Address for trusted domain from list on intranet Outlook VBA and Custom Forms 4
J How do you disable address search box when typing @ in body of email? Using Outlook 0
S HTML Code Embedded in String Within Open Outlook Email Preventing Replace(Application.ActiveInspector.CurrentItem.HTMLBody From Working Outlook VBA and Custom Forms 4
Victor.Ayala Automated way to check the option "Show this folder as an email Address Book" Outlook VBA and Custom Forms 2
D Wrong email address in Outlook 2003 "From" tab in new outgoing emails Using Outlook 4
D Forwarding email based on the attachment file type and specific text found on the attachment file name Outlook VBA and Custom Forms 1
F Forward incoming email with 4 embedded images in the body without original sender Outlook VBA and Custom Forms 22
W Macro to Filter Based on Latest Email Outlook VBA and Custom Forms 6
D Create advanced search (email) via VBA with LONG QUERY (>1024 char) Outlook VBA and Custom Forms 2
C Outlook 2007 Removing then adding account restores junk email processing Using Outlook 0
G Place jpg in body of email Outlook VBA and Custom Forms 1
F Wishlist Outlook suddenly began synchronizing deleted items every time I delete a single email. Using Outlook 2
N Save Selected Email Message as .msg File Outlook VBA and Custom Forms 12
HarvMan Toggle between calendar and email in Outlook 365 Using Outlook 12
F Email being marked as Spam by Gmail and not being visible in Outlook Using Outlook 5
G Email time stamp Using Outlook 2
G Schedule recurring email and attachments display Outlook VBA and Custom Forms 3
G Save and Rename Outlook Email Attachments Outlook VBA and Custom Forms 0
B Need to Copy an email to a subfolder Outlook VBA and Custom Forms 2
M How to setup outlook after importing old account information - Entering email account info creates with "(1)" after the account! Using Outlook 1
K Multiple Rules on Single Email Using Outlook 2
F VBA to move email from Non Default folder to Sub folders as per details given in excel file Outlook VBA and Custom Forms 11
e_a_g_l_e_p_i Outlook 2010 How to set default email address for website links Using Outlook 3

Similar threads

Top