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

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:

Code:

---

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?

I realised this forum makes pics thumbnails.
Here is a pic with higher resolution.l

https://www.instagram.com/p/CLeUfLQn..._web_copy_link
https://bit.ly/3bjpAea

Frankly I wouldn't do it like that.

I would use a Rule to identify the incoming messages and move them to the appropriate sub folder, associated with a script to save the attachments in a Windows folder of your choice.
The script below will save only pdf files. Modify as appropriate to get only the files you want, bearing in mind that any graphics in the message will count as attachments.
You can use the test message to test the code with a message already received, before committing it to a rule.
If there is no script option in rules - see https://www.slipstick.com/outlook/ru...-script-rules/
See also http://www.vbaexpress.com/forum/show...ttachments-VBA

Code:

---

Sub SaveAttachments(Item As Outlook.MailItem)
Const strPath As String = "S:\Path\"
Dim olAtt As Attachment
Dim strExt As String
Dim strFilename As String
    If TypeName(Item) = "MailItem" Then
        If Item.Attachments.Count > 0 Then
            For Each olAtt In Item.Attachments
                strExt = LCase(Mid(olAtt.FileName, InStrRev(olAtt.FileName, Chr(46))))
                If strExt = ".pdf" Then 'e.g. save only pdf file attachments
                    strFilename = strPath & olAtt.FileName
                    olAtt.SaveAsFile strFilename
                End If
            Next olAtt
        End If
    End If
lbl_Exit:
    Exit Sub
End Sub

Sub TestMacro()
Dim olMsg As MailItem
    On Error Resume Next
    Select Case Outlook.Application.ActiveWindow.Class
        Case olInspector
            Set olMsg = ActiveInspector.currentItem
        Case olExplorer
            Set olMsg = Application.ActiveExplorer.Selection.Item(1)
    End Select
    SaveAttachments olMsg
lbl_Exit:
    Exit Sub
End Sub

---

Hi Gmayor,
Thank you for your reply, very nice code: the code indeed works with a rule; however, on our exchange server, rules won't run automatically for some reason...

Probably this from the spiceworks forum is why:

Quote:

---

Outlook rules and journalling on mailboxes that have an alias listed as the "JournalingReportNdrTo" in an Exchange transport rule do not run. This is a new security feature for newer versions of Exchange Server.
Once I changed the JournalingReportNdrTo to another account this it resolved my issue!

---

I was wondering if you knew whether there is there a way to use a vb script file through task scheduler in order to run your macro?

If you can't run rules, then I guess we are back to Events :(
Try the following which is closely based on the code I posted earlier.. You can test it by running 'Application_Startup' from the VBA editor then drag a suitable message to the inbox of the account. It should work if the account display name is correct, the sender e-mail address is correct and the path exists. If you change anything run the aforementioned macro again to reset.

Code:

---

Option Explicit
Private WithEvents Items As Outlook.Items
Const strAcc = "LogisticsSupport@thecompany.com" 'account displayname
Const strPath As String = "S:\Path\" 'folder to save the attachments


Private Sub Application_Startup()
Dim olFolder As Outlook.Folder
Dim olAccount As Account
    For Each olAccount In Session.Accounts
        If olAccount.DisplayName = strAcc Then
            Set olFolder = olAccount.DeliveryStore.GetDefaultFolder(olFolderInbox)
            Set Items = olFolder.Items
            Exit For
        End If
    Next olAccount
End Sub


Private Sub Items_ItemAdd(ByVal item As Object)
Dim olAtt As Attachment
Dim strExt As String
Dim strFilename As String
    If TypeName(item) = "MailItem" Then
        If item.SenderEmailAddress = "reports@thecompany.com" Then
            If item.Attachments.Count > 0 Then
                For Each olAtt In item.Attachments
                    strExt = LCase(Mid(olAtt.FileName, InStrRev(olAtt.FileName, Chr(46))))
                    If strExt = ".pdf" Then    'e.g. save only pdf file attachments
                        strFilename = strPath & olAtt.FileName
                        olAtt.SaveAsFile strFilename
                    End If
                Next olAtt
            End If
        End If
    End If
lbl_Exit:
    Exit Sub
End Sub

---