Save and rename outlook email attachments to include domain name & date received

[weslake77]

Hi all,
I'm not a developer and quite the beginner. I work for my family on a farm and we have a heap of invoices coming in each month via email and I'd love to be able to create a macro that allows all attachments that are invoices or statements to be saved to a file on my computer.
I have a macro that is currently functioning well that pulls all attachments that include the words Ïnvoice or Statement into a folder on my computer.
This is it below:

Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "C:\Users\Sarah\OneDrive\Accounts & Invoices\2018\Email Invoice Attachments\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next
End Sub

But now I have a huge file filled with a bunch of files (invoices and statements) that are badly named and I don't know what they are unless I open them up.
So, I'd love to be able to rename the attachment to include the email domain & the date received.
For example - I get an invoice from a company called Queensland Bearings - their email address is "admin@queenslandbearings.com.au" and the email was received on the 1st April 2018. I would like the attachment to be saved as "QueenslandBearings-20180401"
Can someone please help me with the code for this?
Greatly appreciated
Sarah.

 

[weslake77]

Hi all, pretty desperate for a reply. Your help would be greatly appreciated

 

[niton]

You can extract somewhat useful information out of SenderEmailAddress.

Public Sub SaveAttachmentsToDisk(MItem As mailItem)

    Dim oAttachment As attachment
    Dim sSaveFolder As String
 
    Dim sndrEmailAdd As String
    Dim sndrEmailRight As String
    Dim sndrEmailPreDot As String
    
    Dim saveName As String
 
    ' Try on a test folder not your current folder
    sSaveFolder = "C:\Users\Sarah\OneDrive\Accounts & Invoices\2018\Email Invoice Attachments\"
        
    '  Extract text, after @ and before dot, from the email address.
    sndrEmailAdd = MItem.SenderEmailAddress
        
    'Debug.Print sndrEmailAdd
    'Debug.Print " position of @ sign: " & InStr(sndrEmailAdd, "@")
    'Debug.Print " number of characters right of @ sign: " & Len(sndrEmailAdd) - InStr(sndrEmailAdd, "@")
    
    sndrEmailRight = Right(sndrEmailAdd, Len(sndrEmailAdd) - InStr(sndrEmailAdd, "@"))
    'Debug.Print " text after @ sign: " & sndrEmailRight
    
    'Debug.Print " position of the (first) . period in the remaining text: " & InStr(sndrEmailRight, ".")
    sndrEmailPreDot = Left(sndrEmailRight, InStr(sndrEmailRight, ".") - 1)
    
    'Debug.Print " text before . period: " & sndrEmailPreDot
    
    For Each oAttachment In MItem.Attachments
            
        ' Without versioning code,
        '  if more than one attachment with same name they will overwrite.
        ' Would have been doing so previously,
        '  now less likely with the added prefix.
                
        saveName = sSaveFolder & sndrEmailPreDot & "-" & Format(MItem.ReceivedTime, "yyyymmdd") & "-" & oAttachment.DisplayName
        
        oAttachment.SaveAsFile saveName
        
    Next
 
End Sub

Sub saveDocumentsFromPreviouslyReceivedMailWithNewName()
    ' Open one old mail first
    SaveAttachmentsToDisk ActiveInspector.currentItem
End Sub

 

[weslake77]

Thank you so very much for taking the time to reply and send all of that code!
I'll give that go and let you know
Thanks
Sarah

 

[weslake77]

It worked beautifully!!! Thank you so much and also thank you for explaining the steps!! It's greatly appreciated!!
If you have any suggestions as to what websites or course that I should look into to learn VBA that would be great. If not, thanks again for all of your assistance