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

dougmarkham

Board Regular
Joined
Jul 19, 2016
Messages
224
Office Version
  1. 365
Platform
  1. Windows
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.
VBA Code:
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
VBA Code:
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.
VBA Code:
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.
VBA Code:
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:
VBA 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.
VBA 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.
 

Some videos you may like

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.

Watch MrExcel Video

Forum statistics

Threads
1,119,012
Messages
5,575,545
Members
412,677
Latest member
Davejf81
Top