Public Sub Outlook_Save_Emails_To_Folder()
Dim outApp As Outlook.Application
Dim outNamespace As Outlook.Namespace
Dim outSharedMailbox As Outlook.Recipient
Dim outFolder As Outlook.MAPIFolder
Dim outItems As Outlook.Items
Dim outItem As Object
Dim outMailItem As Outlook.MailItem
Dim saveInFolder As String
Dim sharedMailbox As String, senderEmailAddress As String
Dim filter As String
Dim n As Long
saveInFolder = "P:\responses\" & Format(Date, "yyyy-mm-dd") & "\"
If Dir(saveInFolder, vbDirectory) = vbNullString Then MkDir saveInFolder
sharedMailbox = "shared.email@address.com"
senderEmailAddress = "vendor@abc.com"
Set outApp = GetObject(, "Outlook.Application")
If outApp Is Nothing Then Set outApp = New Outlook.Application
Set outNamespace = outApp.GetNamespace("MAPI")
Set outSharedMailbox = outNamespace.CreateRecipient(sharedMailbox)
outSharedMailbox.Resolve
If outSharedMailbox.Resolved Then
Set outFolder = outNamespace.GetSharedDefaultFolder(outSharedMailbox, OlDefaultFolders.olFolderInbox)
Else
MsgBox "Unable to get Inbox folder for shared mailbox '" & sharedMailbox & "'. Using default Inbox folder instead.", vbExclamation
Set outFolder = outNamespace.GetDefaultFolder(OlDefaultFolders.olFolderInbox)
End If
filter = "[SenderEmailAddress] = '" & senderEmailAddress & "'"
n = 0
Set outItems = outFolder.Items.Restrict(filter)
For Each outItem In outItems
If outItem.Class = OlObjectClass.olMail Then
Set outMailItem = outItem
outMailItem.SaveAs saveInFolder & ReplaceInvalidChars(outMailItem.Subject) & ".msg", OlSaveAsType.olMsg
n = n + 1
End If
Next
MsgBox "Done." & vbCrLf & vbCrLf & n & IIf(n = 1, " email", " emails") & " saved in " & saveInFolder, vbInformation
End Sub
Private Function ReplaceInvalidChars(fileName As String) As String
'Replace invalid characters in a file name with a space
Const InvalidChars As String = "\/:*>""<>|"
Dim i As Long
ReplaceInvalidChars = fileName
For i = 1 To Len(fileName)
ReplaceInvalidChars = Replace(ReplaceInvalidChars, Mid(InvalidChars, i, 1), " ")
Next
End Function