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
Next
End If
End Sub




'Delete the temporary email and file

MsgEmail.Delete
Set MsgEmail = Nothing
Kill MsgFileName

End If
Next

End If

Next

MsgBox "Completed", vbInformation

End Sub

Looks like all the pieces are there.

Code:

---

Sub Button4_Click()

' Code for Excel
' Set a reference to Microsoft Outlook Object Model

' Strictly speaking, needed for Outlook 2003 and prior
' At some point in the future MAPIFolder may no longer be accepted in 2007 and subsequent.
'Dim OLF As Outlook.MAPIFolder
Dim OLF As Outlook.Folder

Dim oMAPI As Outlook.Namespace
Dim Mailbox As String

'Dim Folder As String  ' Folder is allowed but it already has a meaning
Dim srchFolder As String

Dim OutlookApp As Outlook.Application

'If used, set True when New Outlook.Application to decide if Outlook can be closed
' Dim bFlag As Boolean

Dim OutlookItem As Object
Dim Email As Outlook.MailItem
Dim OutlookAttachment As Outlook.Attachment
Dim MsgEmail As Outlook.MailItem
Dim MsgFileName As String
Dim olContacts As Outlook.Items
Dim obj As Object

' Only if you cannot figure out what to use. Same as Dim objVariant
'Dim objVariant As Variant
Dim objContact As ContactItem

Dim olCategory As String

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

' One of the few valid uses of On Error Resume Next
On Error Resume Next

' Bybass the error if GetObject fails to find a running Outlook application.
Set OutlookApp = GetObject(, "Outlook.Application")

' Turn off the error bypass immediately once the specific purpose is served
' Consider mandatory whenever On Error Resume Next is used
On Error GoTo 0

' If Set OutlookApp = GetObject(, "Outlook.Application") failed you bypassed an error.
' OutlookApp may not have been set to anything and you want a running instance of Outlook.
If OutlookApp Is Nothing Then Set OutlookApp = New Outlook.Application

Set oMAPI = OutlookApp.GetNamespace("MAPI")

'Set OLF = oMAPI.Folders.Item(Mailbox).Folders(Folder)
Set OLF = oMAPI.Folders.Item(Mailbox).Folders(srchFolder)

'Loop through items in folder
For Each OutlookItem In OLF.Items
    'If this item is an email
    If OutlookItem.Class = Outlook.OlObjectClass.olMail Then
   
        'Debug.Print OutlookItem.Subject
       
        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 Then
           
                If Right(OutlookAttachment.Filename, 4) = ".msg" Then
   
                    'Save it as a temporary file
                    ' Normally a trailing slash is good,
                    '  maybe not strictly necessary here with the temp folder and the Kill
                    Debug.Print "Environ( temp ): " & Environ("temp")
                    Debug.Print "Environ( temp ), 1: " & Right(Environ("temp"), 1)
                    If Right(Environ("temp"), 1) = "\" Then
                        MsgFileName = Environ("temp") & Trim(OutlookAttachment.Filename)
                    Else
                        MsgFileName = Environ("temp") & "\" & Trim(OutlookAttachment.Filename)
                    End If
                    'Debug.Print "MsgFileName: " & MsgFileName
                   
                    OutlookAttachment.SaveAsFile MsgFileName
       
                    'Create a temporary in-memory email message from the file
                    Set MsgEmail = OutlookApp.CreateItemFromTemplate(MsgFileName)
                   
                    'Apply category based on contact
                    Set olContacts = oMAPI.GetDefaultFolder(olFolderContacts).Items
                   
                    For Each obj In olContacts
                       
                        If TypeOf obj Is ContactItem Then
                           
                            'Set objVariant = obj
                            Set objContact = obj
                           
                            If LCase(objContact.Email1Address) = LCase(MsgEmail.SenderEmailAddress) Then
                                Email.Display
                                Debug.Print objContact.Email1Address
                                Debug.Print MsgEmail.SenderEmailAddress
                                olCategory = objContact.Categories
                               
                                ' Note: This replaces any existing categories on the mail
                                Email.Categories = olCategory
                                Email.Save
                                Exit For
                            End If
                        End If
                    Next
                End If
            End If
        Next
    End If
Next

'Delete the temporary email and file
MsgEmail.Delete
Set MsgEmail = Nothing
Kill MsgFileName

MsgBox "Completed", vbInformation

End Sub

---