Saving Emails from specific sender to folder on hard drive

[Holley]

Hello all and many thanks for past help. Reaching out once again because I am trying to create an Excel spreadsheet that will allow me to create a button that will allow me a way to save all the emails in the inbox from a specific sender (vendor@abc.com) - this is a shared mailbox- to a folder on a shared hard drive (P:\responses) I would like to create a subfolder with the current date and have the emails saved there. Access to creating and running macros is disabled within Outlook, but we can use them in Excel. Any assistance would be most appreciated in tackling this. Thanks again in advance!!

 

[John_w]

Try this Excel VBA macro. You must set a reference to Microsoft Outlook nn.0 Object Library, via Tools -> References in the VBA editor, otherwise the code won't compile or run.

I don't have a shared mailbox to test it with, so if the shared mailbox isn't found the code uses the default Inbox instead. Change the sharedMailbox string in the code as needed.

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

 

[Holley]

Thanks for your help and sorry for such a long delay in responding. Just getting to work with this. I am getting a "Compile Error: Expected End Sub right after this line...
MsgBox "Done." & vbCrLf & vbCrLf & n & IIf(n = 1, " email", " emails") & " save

 

[John_w]

Is the End Sub missing?

 

[Holley]

It didn't, but added. Now I'm getting a Runtime error 287 at the outSharedMailbox.Resolve I did add the "to" email address in the sharedMailbox line. Is this the correct location? I am very new to VBA and not certain the required syntax.

 

[John_w]

I did add the "to" email address in the sharedMailbox line. Is this the correct location?

Yes, that sounds correct.

Try either or both of the following changes:

1. Change the sharedMailbox string to the mailbox or account name, not its email address.

2. Replace:

    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

with:

    Set outSharedMailbox = outNamespace.CreateRecipient(sharedMailbox)
    Set outFolder = outNamespace.GetSharedDefaultFolder(outSharedMailbox, OlDefaultFolders.olFolderInbox)

If no joy, I can't really help further, so you might need a bit of trial and error using bits of code found on the internet.

 

[Holley]

Thanks again for all of your help! I did get further, but now get the Run Time is on line outMailItem.SaveAs saveInFolder & ReplaceInvalidChars(outMailItem.Subject) & ".msg", OlSaveAsType.olMSG I'll keep searching!! Thank you so much for getting me this far!

 

[John_w]

What's the full error message?

If it got to that line it means it found email(s) from your sender and is trying to save the email as a .msg file in "P:\responses\YYYY-MM-DD\" (current date) with the email subject (with invalid characters replaced by space) as the file name. Does "P:\responses\" exist? Can you manually save an email in that folder?

 

[Holley]

Hope this helps...

 

[John_w]

Google "outlook vba saveas run-time error 287".

It seems to be related to security policies for Outlook.

Try saving an email (as Outlook Message Format) in that folder.