Categorize received emails based on the sender of the attached message

[lemonpartyz]

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

[skatonni]

Looks like all the pieces are there.


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