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)

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?

[dougmarkham]

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

https://www.instagram.com/p/CLeUfLQnh6e/?utm_source=ig_web_copy_link
https://bit.ly/3bjpAea

[gmayor]

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/rules/outlook-run-a-script-rules/
See also http://www.vbaexpress.com/forum/showthread.php?62114-Pulling-Specified-Attachments-VBA


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

[dougmarkham]

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:

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?

[gmayor]

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.

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