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

[dougmarkham]

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.