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

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

Answer 1

Issue 1 :
You probably have so meeting invites or something other than a regular mail in your folder.
Check the Class property of the Item to see if it's olMail
Issue 2 :
I'll go with error handling, here :
Save in temp folder with the appropriate name
Open the file
Try to get to the sheets
If there is an error, just close the file
If there is no error, save the file in destination folder
Full code :
Sub email_DGMS89()
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
Dim TempFolder As String: TempFolder = VBA.Environ$("TEMP")
Dim wB As Excel.Workbook
'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
'''Const olMail = 43 (&H2B)
If olFolder.items(i).Class <> olMail Then
Else
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
For j = 1 To .Attachments.Count
strName = .Attachments.Item(j).DisplayName
'check if file already exists
If Not Dir(sPathstr & "\" & strName) = vbNullString Then
strName = "(1)" & strName
Else
End If
'''Save in temp
.Attachments(j).SaveAsFile TempFolder & "\" & strName
ThisWorkbook.Worksheets("FileNames").Range("A" & h) = strName
'''Open file as read only
Set wB = workbooks.Open(TempFolder & "\" & strName, True)
DoEvents
'''Start error handling
On Error Resume Next
Set sh = wB.sheets("ASK")
Set sh = wB.sheets("BID")
If Err.Number <> 0 Then
'''Error = At least one sheet is not detected
Else
'''No error = both sheets found
.Attachments(j).SaveAsFile sPathstr & "\" & strName
End If
Err.Clear
Set sh = Nothing
wB.Close
On Error GoTo 0
h = h + 1
Next j
End With
End If
End If
Next i
Application.ScreenUpdating = True
MsgBox "Download complete!", vbInformation + vbOKOnly, "Done"
End Sub