# Outlook VBA - download attachment(s) to a windows folder when email(s) from specific email address lands in the inbox?



## dougmarkham (Nov 10, 2020)

Hi Folks,

*Circumstance:*

In my work Outlook account, I have 3 inboxes:
1 - My work email address
2 & 3 -  group inboxes

i.e.,
DougM@theworkemail.com
*Inbox
LogisticsImages (logisticsimages@theworkemail.com)
*Inbox
*LogisticsSupport (logisticssupport@theworkemail.com)
*Inbox*

Every day, a report is sent to the LogisticsSupport inbox from reports@theworkemail.com---an email that comes with an excel spreadsheet attachment.

```
Set InboxItems = Session.Folders("LogisticsSupport").Folders("Inbox").Items
```

*Goals:*

a) To Save the attachment(s) from reports@theworkemail.com emails---directly after they drop into LogisticsSupport inbox---to the windows folder, *C:\Users\DougM\Desktop\Reports\ *--- I must avoid overwriting files during the SaveAs event!

b) To move the new email from the Inbox to a subfolder called *Reports *

```
Set FldrDest = Session.folders("LogisticsSupport").folders("Inbox").folders("Reports")
```

I have met a variety of VBA coding possibilities for this task, and am having trouble getting any of them to work. I have some code which is specifically written for the latest excel version, so I'm trying to modify this to get it to work. Please would you help me trouble-shoot the code I have, or suggest functional alternatives?

*Code:

Event code:* Sets-off a processing macro with events.

```
Option Explicit

Private WithEvents InboxItems As Items

Private Sub Application_Startup()
Set InboxItems = Session.Folders("LogisticsSupport").Folders("Inbox").Items
End Sub

Private Sub InboxItems_ItemAdd(ByVal ItemCrnt As Object)

With ItemCrnt
     If .Class = olMail Then
          If .SenderEmailAddress = "reports@theworkemail.com" Then
               Call SaveAttachAndMoveEmail(ItemCrnt)
          End If
     End If
End With

End Sub
```

*Processing code:* saves attachments and moves the email.

```
Public Sub SaveAttachAndMoveEmail(ByRef ItemCrnt As MailItem)

Dim Attach As Attachment
Dim FldrDest As Folder
Dim PathSave As String

PathSave = "C:\Users\DougM\Desktop\Reports\"

Set FldrDest = Session.Folders("LogisticsSupport").Folders("Inbox").Folders("Reports")

With ItemCrnt
     For Each Attach In .Attachments
          With Attach
               .SaveAsFile PathSave & "\" & .DisplayName
          End With
     Next

     If .Parent.Name = "Reports" And .Parent.Parent.Name = "Inbox" Then
          'MailItem is already in destination folder
     Else
          .Move FldrDest
     End If

End With

End Sub
```

*Issues I'm having with my code:*

1) The event code doesn't do anything
2) Currently, the processing code will overwrite files with the same name as the attachment.

To trouble-shoot the event code, I have run a sub by the same author i.e., which allows manual launch but which sets-off the same processing code:

```
Sub SelectEmailsScan()

Dim FldrSrc As Folder
Dim InxItemCrnt As Long

Set FldrSrc = Session.Folders("LogisticsSupport").Folders("Inbox")

For InxItemCrnt = FldrSrc.Items.Count To 1 Step -1
     With FldrSrc.Items.Item(InxItemCrnt)
          If .Class = olMail Then
              If .SenderEmailAddress = "reports@theworkemail.com" Then
                    Call SaveAttachAndMoveEmail(FldrSrc.Items.Item(InxItemCrnt))
              End If
          End If
     End With
Next

End Sub
```

Going through this using F8--line by line--shows that emails from reports@theworkemail.com sat in the Inbox are not being detected by the below code.

```
If .SenderEmailAddress = "reports@theworkemail.com" Then
   Call SaveAttachAndMoveEmail(FldrSrc.Items.Item(InxItemCrnt))
```


Please would you help me modify above event code and processing code so that it saves the attached *.xls* file with a unique filename and then moves the email to the Reports folder?

Kind regards,

Doug.


----------

