Outlook VBA: Moving email and saving attachments to specified folder -2nd'ry email ad

[dougmarkham]

Hi Everyone,

Briefly...

Goal:

To move daily emails sent to a secondary inbox --- i.e., sent from a specific email address---to a sub-folder (Reports) and save the attachment to a location on our network.


System Specifics:

OS: Windows 7 Pro & Windows 10
Outlook: version 365
Email server: Microsoft Exchange


Progress:

I have some VBA that I found on via Google which someone else has gotten to work. However, there are some differences in my situation.

1) I have two email accounts---a primary one (my own email address) and secondary account (an email group called: LogisticsSupport, that has a group email address, the send to!). I would like to VBA to refer to the secondary group email account/address.

2) The folder I wish to download attachments to is on a network drive: see pic for details (email addresses & folderpath disguised)

Attachment 27971


VBA so far:

Private WithEvents Items As Outlook.Items
 
'location to save in.  Can be root drive or mapped network drive.
'-->As it is a constant you can declare it there (and so, use it in the whole module if you want to do other things with it!)
Private Const attPath As String = "S:etc"
 
 
Private Sub Application_Startup()
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
 
Private Sub Items_ItemAdd(ByVal item As Object)
 
On Error GoTo ErrorHandler
    'Only act if it's a MailItem
    If TypeName(item) = "MailItem" Then
        Dim Msg As Outlook.MailItem
        '-->Use directly the parameter and keep it under wraps using "With", it'll improve efficiency
        With item
            'Change variables to match need. Comment or delete any part unnecessary.
            If (.SenderEmailAddress = "reports email address (below pic/instagram-post)" _
               Or .Subject = "LOG Leicester | Weekly Despatches by Courier and Customer" _
               ) _
               And .Attachments.Count >= 1 Then
 
 
                Dim aAtt As Outlook.Attachment
                '-->Loop through the Attachments' collection
                For Each aAtt In item.Attachments
                    '-->You can either use aAtt.DisplayName or aAtt.FileName
                    '-->You can test aAtt.Size or aAtt.Type
 
                    'save attachment
                    aAtt.SaveAsFile attPath & aAtt.DisplayName
                Next aAtt
 
                'mark as read
                .UnRead = False
 
                Dim olDestFldr As Outlook.MAPIFolder
                Set FldrDest = Session.folders("LogisticsSupport").folders("Inbox").folders("Reports")
                If .Parent.Name = "Reports" And .Parent.Parent.Name = "Inbox" Then
                    'MailItem is already in destination folder
                Else
                    Set Msg = .Move(FldrDest)
                    MsgBox Msg.SenderEmailAddress & vbCrLf & Msg.Subject
                    'Msg.delete
                End If
            End If
        End With 'item
    End If
 
 
ProgramExit:
  Exit Sub
 
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

I've put this code into: ThisOutlookSession (not a module). As far as I understand it, when Outlook opens, the VBA directs an inbox search for mail sent from the senders email address (see pic) to the secondary email account (see pic). I think I need to refer specifically to the secondary email account somehow in order for it to search the correct inbox (see picture for details).

Please would you help me understand/modify this VBA to do the job?