VBA program to automatically move emails between folders based on email address

[jwerth]

<sub>Hello,

This is my first time posting on the forum and I have never used the vba language in outlook and have used in minimally in excel. The group I work with is currently facing a problem where we receive a large number of emails that are not relevant and waste a good chunk of our time every day. I would like to eventually have a macro that redirects all emails to folders based on a string within the email address that the email was sent from. Right now I would like to create a test program that I can alter for my eventual desired intent.

I would like to have a program in VBA for outlook that will move emails from my "inbox" to a sub folder of inbox titled "My Emails" as well as "My Emails (Internal)" based on whether a certain string is within the email address that the email was sent from. If the email address that the message was sent from has "werth" in the address than I would like it directed to "My Emails". If the email address that the email was sent from has "jaw" in it than I want it directed to "My Emails (Internal)".

This is what I have written, or taken from other peoples programs. It doesn't run any help would be appreciated:</sub>

Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.Folders("inbox")
End Sub


Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim msg As Outlook.MailItem
Dim destFolder As Outlook.MAPIFolder
If TypeName(item) = "MailItem" Then
    Set msg = item
    ' check if sender email address field contains "werth"
    If InStr(msg.SenderEmailAddress, "werth") > 0 Then
        Set destFolder = Outlook.Session.Folders("My Emails")
        ' check if sender email address field contains "jaw"
        If InStr(msg.SenderEmailAddress, "jaw") > 0 Then
            Set destFolder = Outlook.Session.Folders("My Emails")
        End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

[gmayor]

You should be able to do this with a pair of Outlook rules, one for each address type, without then need for a macro.

Your macro has IF conditions that are not closed, and the folder settings are not valid. Having set a folder, you don't then move the message to the folder, but apart from that the idea is not far adrift.

The second macro (not tested) can be used from a rule, or it can be called by the first listed macro to process selected messages:

Option Explicit

Sub MoveSelected()
'Graham Mayor - http://www.gmayor.com - Last updated - 22/11/2016
Dim olItem As Object
    For Each olItem In Application.ActiveExplorer.Selection
        If olItem.Class = OlObjectClass.olMail Then
            MoveMessage olItem
        End If
    Next olItem
    Set olItem = Nothing
lbl_Exit:
    Exit Sub
End Sub


Private Sub MoveMessage(ByVal item As Object)
'Graham Mayor - http://www.gmayor.com - Last updated - 22/11/2016
    On Error GoTo ErrorHandler
    Dim destFolder As Outlook.MAPIFolder
    If TypeName(item) = "MailItem" Then
        ' check if sender email address field contains "werth"
        If InStr(item.SenderEmailAddress, "werth") > 0 Then
            Set destFolder = Session.GetDefaultFolder(olFolderInbox).folders("My Emails")
            item.Move destFolder
            ' check if sender email address field contains "jaw"
        ElseIf InStr(item.SenderEmailAddress, "jaw") > 0 Then
            Set destFolder = Session.GetDefaultFolder(olFolderInbox).folders("My Emails")
            item.Move destFolder
        End If
    End If
ProgramExit:
    Set destFolder = Nothing
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Err.Clear
    GoTo ProgramExit
End Sub

[jwerth]

Unfortunately I cannot get the program to run. I should mention that I need the program to run every time I receive an email and every time I start up outlook for unread emails. I tried to using your code and adding an events handler for receiving email's, but still had no luck. Thanks so much for your help.

[gmayor]

There are two macros. The first should be run on a selected message (or messages).
The second should be used as a script associated with a rule that runs on received messages.
You don't need the event handler. You don't really need the macro as this can be done with a pair of rules (one for each e-mail address string). I use many such rules to direct incoming mail to a variety of folders.

[jwerth]

I don't know if rules would work. Because I am in constant contact with new people from a given company I need to look for a sub string within the senders email address. Not have the emails organized based on the entire string of the senders email. I don't really understand how to do this without an event handler. I don't think I understand enough about outlook methods/properties. How would you write this without an event handler? Also your website has been a great help with some other problems I have been having.

Thank you,
Justin

[jwerth]

Still needing assistance with program if anyone has any tips!

Thanks,
Justin

[gmayor]

You can set up a rule to look for 'specific words in the sender's address'. This can be a domain name e.g. '@gmayor.com' would work with e-mails from my server.