Solved

Scan and move email messages to specific folders based on subject line information

Posted on 2015-01-26
5
27 Views
Last Modified: 2016-05-31
Let me see if I can describe what I am looking for below.
We have a mailbox where all of our project related emails are being BCC'd. The folder is 'Project'.  We would like to find a way to scan all of the email that is within this folder and file it according to a project number in the subject line of the email. We are using a custom form to add the project number when the email is being sent out. An example subject line would be:
Austin Project One -R21334322. The project number starts with the letter "R".
Here is the kicker, we would like for it to not only scan and move the emails to the correct Project folder, but if the project number folder does not exist, we would like for the macro to create it and then move the emails related to it.
I know this may be difficult to understand clearly, so I will attach a screenshot.
screenshot
Any help on this would be appreciated. Also, should you have additional questions, please let me know. Thanks again.
0
Comment
Question by:blkstrim
  • 2
5 Comments
 
LVL 18

Expert Comment

by:Simon
ID: 40572183
Do you want to file the emails in subfolders in the mailbox or a folder hierarchy within your Windows filesystem?
0
 

Author Comment

by:blkstrim
ID: 40572879
I would like to file them in subfolders in the mailbox. The idea would be that others could view them if we shared the folders out. So it would look something like this

Project (where the emails will come into originally)
      --> R21334341
      --> R22134432

Thanks. I should have been clear on that.
0
 
LVL 18

Accepted Solution

by:
Simon earned 500 total points
ID: 40573382
This works for me in Outlook 2010.
Add the code to a module within Outlook and assign it to a button on the Developer tab of the ribbon, or run it directly from the VBE window for testing.

This is adapted from previously written code and has a few unused variables still in it.

It prompts you to pick a folder each time, but you can hard code it if preferred.
It displays a messagebox and skips the email if it finds more than one projectname string in the email subject
e.g. Subject "for multiple projects - R12345679 and R22345678"

Sub FileInSubfoldersByProjectName_REGEX()
Dim I As Long
Dim olApp As Outlook.Application
Dim olNs As Outlook.NameSpace
Dim olFolder As Outlook.Folder
Dim olItem As Outlook.MailItem
Dim olMailItem As Outlook.MailItem
Dim oNewMailItem As Outlook.MailItem
Dim sFname As String
Dim sPath As String
Dim iMessages As Long
Dim olTestFolder As Outlook.Folder

On Error Resume Next
'Open Outlook

Set olApp = GetObject(, "Outlook.Application")

If Err = 429 Then
     'Outlook is closed so start Outlook

     Set olApp = CreateObject("Outlook.Application")
End If
Set olNs = olApp.GetNamespace("MAPI")

On Error GoTo ErrorTrap
'Locate the folder containing the unprocessed e-mail messages
'Set olFolder = olNs.Folders("Mailbox - ANYMAILBOX"). _

Set olFolder = olNs.PickFolder
If olFolder Is Nothing Then
    MsgBox "No folder was selected for processing.", vbOKOnly + vbInformation, "File Emails by project"
    GoTo CleanExit
End If

'Application.Visible = True
If MsgBox("Are you sure you want to file emails from: " & vbCrLf & vbCrLf & _
    olFolder.Name, vbYesNo + vbQuestion, "Extract Email Attachments") <> vbYes Then
        GoTo CleanExit
End If


If olFolder.Items.Count = 0 Then
    Err.Raise vbObjectError + 1000, "", "No items in folder"
End If

'Examine each message starting from the bottom of the list
For I = olFolder.Items.Count To 1 Step -1
     ' test for item type (this is due to non-email items that can inhabit an email folder in outlook)
     If olFolder.Items(I).Class <> olMail Then
        Debug.Print "Item " & olFolder.Items(I).Name & " being skipped as this is not a mail message."
        GoTo ProcessNextEmail
     End If
     
     Set olItem = olFolder.Items(I)
     Debug.Print "Subject:" & olItem.Subject

    Set rgx = CreateObject("vbscript.regexp")
    rgx.Pattern = "(R[0-9]{8,9})"
    rgx.Global = True
    
    Set matches = rgx.Execute(olItem.Subject)
    If matches.Count = 0 Then
        Debug.Print "No regex matches"
    ElseIf matches.Count = 1 Then
        matchedString = matches.Item(0) '.SubMatches.Item(0)
        Debug.Print matchedString
        On Error Resume Next
        Set olTestFolder = olFolder.Folders(matchedString)
        If Err.Description = "The attempted operation failed.  An object could not be found." Then
        On Error GoTo 0
        olFolder.Folders.Add matchedString
        End If
        olItem.Move olFolder.Folders(matchedString)
        On Error GoTo ErrorTrap
    ElseIf matches.Count > 1 Then
        MsgBox "Multiple regex matches for email subject line " & vbCrLf & vbCrLf & olItem.Subject & vbCrLf & vbCrLf & "Please edit subject or file manually", vbOKOnly + vbExclamation
    End If

ProcessNextEmail:
Next I ' Next email

MsgBox "Filing process completed."

CleanExit:
Set olItem = Nothing
Set olFolder = Nothing
Set olNs = Nothing
Set olApp = Nothing
Exit Sub

ErrorTrap:
Debug.Print Err.Number & Err.Description
MsgBox "Runtime error: " & Err.Number & " - " & Err.Description & vbCrLf & vbCrLf & _
        "Please keep this box displayed on your screen and contact your administrator.", vbOKOnly + vbCritical
Resume CleanExit

End Sub

Open in new window

0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Follow this checklist to learn more about the 15 things you should never include in an email signature from personal quotes, animated gifs and out-of-date marketing content.
If you don't know how to downgrade, my instructions below should be helpful.
This video walks the viewer through the process of creating envelopes and labels, with multiple names and addresses. Navigate to the “Start Mail Merge” button in the Mailings tab: Follow the step-by-step process until asked to find the address doc…
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

932 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now