VBA to loop through email attachments and save based on given criteria

Question

This is a follow up from a previous question (VBA to save attachments (based on defined criteria) from an email with multiple accounts)

Scenario: I have a code that loops through all e-mails in a certain outlook account, and saves the attachments to a selected folder. Previously, my problem was selecting which folder (and account) from where to extract the attachments (this was solved with a suggestion from the previous question).

Issue 1: The code is presenting a "Type Mismatch" error at the line:

Set olMailItem = olFolder.Items(i)

Issue 2: As stated in the question title, my main objective is to loop through all the attachments and save only those that have a given criteria (excel file, with one sheet name "ASK" and one named "BID"). More than a simple If to account for these criteria, I have to either download all files to "temp folder", to the selection and put the final resulting files in the output folder, or download everything to the final folder and delete the files that do not meet the criteria.

Problem: I can't seem to find the way to do either of those operations.

Question: How would one do that? And which of those two would be more efficient?

Code:

Sub email()

Application.ScreenUpdating = False

Dim olApp As New Outlook.Application
Dim olNameSpace As Object
Dim olMailItem As Outlook.MailItem
Dim olFolder As Object
Dim olFolderName As String
Dim olAtt As Outlook.Attachments
Dim strName As String
Dim sPath As String
Dim i As Long
Dim j As Integer
Dim olSubject As String
Dim olSender As String
Dim sh As Worksheet
Dim LastRow As Integer

'delete content except from row 1
ThisWorkbook.Worksheets("FileNames").Rows(2 & ":" & ThisWorkbook.Worksheets("FileNames").Rows.count).Delete

'set foldername and subject
olFolderName = ThisWorkbook.Worksheets("Control").Range("D10")
'olSubject = ThisWorkbook.Worksheets("Control").Range("D16")
olSender = ThisWorkbook.Worksheets("Control").Range("D16")

sPath = Application.FileDialog(msoFileDialogFolderPicker).Show
sPathstr = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

Set olNameSpace = olApp.GetNamespace("MAPI")

'check if folder is subfolder or not and choose olFolder accordingly
'Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders(olFolderName)
Set olFolder = olNameSpace.Folders("email@email.com").Folders("Inbox")

If (olFolder = "") Then
    Set olFolder = olNameSpace.Folders("email@email.com").Folders("Inbox")
End If

'loop through mails
h = 2
For i = 1 To olFolder.Items.count
    Set olMailItem = olFolder.Items(i)

    'check if the search name is in the email subject
    'If (InStr(1, olMailItem.Subject, olSubject, vbTextCompare) <> 0) Then
    If (InStr(1, olMailItem.Sender, olSender, vbTextCompare) <> 0) Then

        With olMailItem

                strName = .Attachments.Item(j).DisplayName

                'check if file already exists
                If Not Dir(sPathstr & "\" & strName) = "" Then
                .Attachments(j).SaveAsFile sPathstr & "\" & "(1)" & strName
                ThisWorkbook.Worksheets("FileNames").Range("A" & h) = "(1)" & strName
                Else
                .Attachments(j).SaveAsFile sPathstr & "\" & strName
                ThisWorkbook.Worksheets("FileNames").Range("A" & h) = strName
                End If

                h = h + 1
            Next

        End With

    End If
Next 

Application.ScreenUpdating = True
MsgBox "Download complete!", vbInformation + vbOKOnly, "Done"

End Sub

VBA to loop through email attachments and save based on given criteria

1 Answers