Categorize received emails based on the sender of the attached message

  • Hey Y'all I'm having a ton of trouble with this code, there's probably a better way to do it so I'm totally open to suggestions.

    Basically I receive a multitude of emails in a day that have an attached message. Basically, people submit messages for me to review. I then categorize those emails based on whatever criteria and then do a bulk reply to those emails that have been categorized.

    Essentially my question is this: Is there a way to automatically categorize an email based on who the sender is in the attached message?

    I'll post my code below. My general idea was to categorize said contact, and then categorize each email based on the matched sender.

    Sub Button4_Click()

    Dim OLF As Outlook.MAPIFolder, oMAPI As Outlook.Namespace
    Dim Mailbox As String, Folder As String
    Dim findString As String
    Dim extractLength As Integer
    Dim OutlookApp As Outlook.Application
    Dim OutlookItem As Object
    Dim Email As Outlook.MailItem
    Dim MsgEmail As Outlook.MailItem
    Dim OutlookAttachment As Outlook.Attachment
    Dim EmailAttachment As Outlook.MailItem
    Dim MsgFileName As String

    Mailbox = Sheets("Setting").Range("B1").Value
    Folder = Sheets("Setting").Range("B2").Value

    Set OutlookApp = GetObject(, "Outlook.Application")
    If OutlookApp Is Nothing Then Set OutlookApp = New Outlook.Application
    Set oMAPI = OutlookApp.GetNamespace("MAPI")
    Set OLF = oMAPI.Folders.Item(Mailbox).Folders(Folder)

    'Loop through items in folder

    For Each OutlookItem In OLF.Items

    'If this item is an email

    If OutlookItem.Class = Outlook.OlObjectClass.olMail Then

    'Search the email body text

    Set Email = OutlookItem

    'For each attachment in this email

    For Each OutlookAttachment In Email.Attachments

    'If this attachment is an email message (.msg)

    If OutlookAttachment.Type = olEmbeddeditem And Right(OutlookAttachment.Filename, 4) = ".msg" Then

    'Save it as a temporary file

    MsgFileName = Environ("temp") & "" & Trim(OutlookAttachment.Filename)
    OutlookAttachment.SaveAsFile MsgFileName

    'Create a temporary in-memory email message from the file

    Set MsgEmail = OutlookApp.CreateItemFromTemplate(MsgFileName)

    'Apply category based on contact

    Private Sub olItems_ItemAdd(ByVal Item As Object)
    Dim oMail As MailItem
    Dim olContacts As Outlook.Items
    Dim obj As Object
    Dim objVariant As Variant
    Dim olCategory As String

    Set olContacts = Outlook.Application.Session.GetDefaultFolder(olFolderContacts).Items

    If TypeOf Item Is MailItem Then
    Set oMail = Item
    For Each obj In olContacts
    If TypeOf obj Is ContactItem Then
    Set objVariant = obj
    If objVariant.Email1Address = oMail.SenderEmailAddress Then
    olCategory = objVariant.Categories
    oMail.Categories = olCategory
    End If
    End If
    End If
    End Sub

    'Delete the temporary email and file

    Set MsgEmail = Nothing
    Kill MsgFileName

    End If

    End If


    MsgBox "Completed", vbInformation

    End Sub

Participate now!

Don’t have an account yet? Register yourself now and be a part of our community!