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

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 :

1. Save in temp folder with the appropriate name
2. Open the file
3. Try to get to the sheets
4. If there is an error, just close the file
5. 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