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