Automatically saving outlook attachments based on title - vba

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.