Consulting

Results 1 to 2 of 2

Thread: Categorize received emails based on the sender of the attached message

  1. #1

    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

  2. #2
    VBAX Mentor skatonni's Avatar
    Joined
    Jun 2006
    Posts
    347
    Location
    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
    To debug, mouse-click anywhere in the code. Press F8 repeatedly to step through the code. http://www.cpearson.com/excel/DebuggingVBA.aspx

    If your problem has been solved in your thread, mark the thread "Solved" by going to the "Thread Tools" dropdown at the top of the thread. You might also consider rating the thread by going to the "Rate Thread" dropdown.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •