Extracting Attachments from Outlook Email

[Photomofo]

Good Evening,

I'm trying to avoid the use of On Error Resume Next. I've never used it until recently when I started building a program that explores new territory for me. Specifically, Send Keys, accessing data from the Clipboard and interrogating Outlook. I've noticed that once you drink the On Error Resume Next tea you end up with all sorts of unintended consequences. So... I'm trying to fix my program so I don't get any errors.

I'm getting an error when I try to grab the File_Name of an attachment. It's saying the attachment has been moved or deleted.

This is the step it's hanging up on. Is there a way to test if an attachment exists? Sorta like If DIR(Path) <> "" then. I couldn't find anything on Google.

File_Name = Email.Attachments.Item(1).Filename

Note also I'm using a for I = 1 to 10 loop. This is because this code doesn't loop through the emails properly. I have no idea why if you have any advice I'd appreciate it.

Here's the entire code.

'The starting structure of this sub was borrowed from: https://stackoverflow.com/questions/45346183/excel-vba-looping-through-all-subfolders-in-outlook-email-to-find-an-email-with

Sub Get_Attachment()

Dim i As Integer
Dim j As Integer
Dim ARG As String
Dim Destination As String
Dim File_Name As String
Dim File_Type As String
Dim Time_Sent As String

Dim Email As Outlook.MailItem
Dim Inbox As Outlook.Items
Dim OutApp As Outlook.Application
Dim Folder As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim Namespace As Outlook.Namespace

Set OutApp = New Outlook.Application
Set Namespace = OutApp.GetNamespace("MAPI")
'On Error Resume Next

'Grabvdata Drive locations
Destination = "C:ABC"

For i = 1 To 10

For Each Folder In Namespace.Folders

If Folder = "ABC" Then

For Each SubFolder In Folder.Folders

If SubFolder = "Inbox" Then

Set Inbox = SubFolder.Items

For Each Email In Inbox

'check for attachments
If Email.Attachments.Count > 0 Then

'loop through all attachments
For j = 1 To Email.Attachments.Count

File_Name = Email.Attachments.Item(1).Filename
Time_Sent = Get_Time_Stamp(Email.SentOn)

'Narrow search to csv attachments
Select Case "csv"

Case "csv"

ARG = Replace(File_Name, ".csv", "", 1)

If ARG = "ABC" Then

If Dir(Destination & "ABC\" & ARG & " - " & Time_Sent & ".csv") = "" Then

ARG = "ABC\" & "ABC" & " - " & Time_Sent & ".csv"
Email.Attachments.Item(j).SaveAsFile Destination & ARG

End If

ElseIf ARG = "ABC" Then

If Dir(Destination & "ABC\" & ARG & " - " & Time_Sent & ".csv") = "" Then

ARG = "ABC\" & "ABC" & " - " & Time_Sent & ".csv"
Email.Attachments.Item(j).SaveAsFile Destination & ARG

End If

ElseIf ARG = "ABC" Then

If Dir(Destination & "ABC\" & ARG & " - " & Time_Sent & ".csv") = "" Then

ARG = "ABC\" & "ABC" & " - " & Time_Sent & ".csv"
Email.Attachments.Item(j).SaveAsFile Destination & ARG
ARG = "ABC" & " - " & Time_Sent & ".csv"
Call Library.This_to_That(ARG)

End If

End If

Email.Delete

End Select

Next

End If

Next Email

End If

Next SubFolder

End If

Next Folder

Next i

End Sub