Automatically saving outlook attachments based on title

Question

I am looking to set up a one drive folder that will hold reports for our companies various clients. Our reporting software only sends to email rather than saving to file so I've googled and found this piece of code to automatically download all attachments to a folder

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
    dateFormat = Format(Now, "yyyy-mm-dd H-mm")
saveFolder = "C:\Report Attachments\"
     For Each objAtt In itm.Attachments
         objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName
          Set objAtt = Nothing
     Next
End Sub

The issue is that I want to split the reports by company. for example, I want reports for Company A to go to

C:\Report Attachments\Company A

and reports for company B to go to

C:\Report Attachments\Company B

and so on. Each report should have the companies name in the title of attachment so I'm looking for a tweak to the code to change the save location based on the attachment title. Is this possible?

Answer 1

Set up a rule to move the emails to specific folders when they arrive (probably rule based on the email address domain).

In the ThisOutlookSession module in Outlook enter this code in the declarations section:

Dim WithEvents CompanyA As Items
Dim WithEvents CompanyB As Items

Const COMPA_PATH As String = "C:\Report Attachments\Company A\"
Const COMPB_PATH As String = "C:\Report Attachments\Company B\"

Private Sub Application_Startup()

    Dim ns As Outlook.NameSpace
    Set ns = Application.GetNamespace("MAPI")

    Set CompanyA = ns.Folders.item("Mailbox - tomdemaine") _
                        .Folders.item("Inbox") _
                        .Folders.item("CompanyA").Items

    Set CompanyB = ns.Folders.item("Mailbox - tomdemaine") _
                        .Folders.item("Inbox") _
                        .Folders.item("CompanyA").Items

End Sub

Sub CompanyA_ItemAdd(ByVal item As Object)

    Dim oAtt As Attachment

    If item.Attachments.Count > 0 Then
        For Each oAtt In item.Attachments
            item.UnRead = False
            'Note DisplayName may contain illegal characters.
            oAtt.SaveAsFile COMPA_PATH & oAtt.DisplayName
            DoEvents
        Next oAtt
    End If

    Set oAtt = Nothing

End Sub

Sub CompanyB_ItemAdd(ByVal item As Object)

    Dim oAtt As Attachment

    If item.Attachments.Count > 0 Then
        For Each oAtt In item.Attachments
            item.UnRead = False
            'Note DisplayName may contain illegal characters.
            oAtt.SaveAsFile COMPB_PATH & oAtt.DisplayName
            DoEvents
        Next oAtt
    End If

    Set oAtt = Nothing

End Sub

The code will start watching your CompanyA & CompanyB folders when you start Outlook. Any time something gets moved there that contains attachments it will save them to your file location and mark the email as read.

I haven't tested the code - and the Outlook folders and file locations will need updating to suit your needs.