download email attachments based on the subject line and folder names from a worksht

[abhay_547]

I got a list of email attachements which i need to download from different folders of outlook in a excel sheet in the below order.

data is in range Row 2 to 10 but can be more in future
Column A: File / attachment name
Column B: Email Subject Line
Column C: Outlook Folder Name
Column D: Save as location for attachements (different for each)

Now I have below function which I got through google search which I want to use, below is what i have put together so far, also I want to add the subject line and filename as string (since I want to name the attachment as its mentioned in the worksheet while saving) which is missing in the function:

Sub Downloademailattachments ()

Dim x As Integer
Dim Attachmentname As String
Dim Outlookfolder As String
Dim Subjectline As String
Dim Filesaveaspath As String




         
      NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
       Range("A2").Select
    
      For x = 1 To NumRows
         Attachmentname = ThisWorkbook.Sheets("Sheet1").Range(Cells(x,1)).Value
Subjectline = ThisWorkbook.Sheets("Sheet1").Range(Cells(x,2)).Value
Outlookfolder = ThisWorkbook.Sheets("Sheet1").Range(Cells(x,3)).Value
Filesaveaspath = ThisWorkbook.Sheets("Sheet1").Range(Cells(x,3)).Value
       

SaveEmailAttachmentsToFolder Outlookfolder, "xls", Filesaveaspath
         ActiveCell.Offset(1, 0).Select
      
Next



End Sub




Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
                                 ExtString As String, DestFolder As String)
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim MyDocPath As String
    Dim I As Integer
    Dim wsh As Object
    Dim fs As Object


    On Error GoTo ThisMacro_err


    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders(OutlookFolderInInbox)


    I = 0
    ' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
               vbInformation, "Nothing Found"
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Exit Sub
    End If


    'Create DestFolder if DestFolder = ""
    If DestFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
        MyDocPath = wsh.SpecialFolders.Item("mydocuments")
        DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
        If Not fs.FolderExists(DestFolder) Then
            fs.CreateFolder DestFolder
        End If
    End If


    If Right(DestFolder, 1) <> "\" Then
        DestFolder = DestFolder & "\"
    End If


    ' Check each message for attachments and extensions
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                FileName = DestFolder & Atmt.FileName
                Atmt.SaveAsFile FileName
                I = I + 1
            End If
        Next Atmt
    Next Item


    ' Show this message when Finished
    If I > 0 Then
        MsgBox "You can find the files here : " _
             & DestFolder, vbInformation, "Finished!"
    Else
        MsgBox "No attached files in your mail.", vbInformation, "Finished!"
    End If


    ' Clear memory
ThisMacro_exit:
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Set fs = Nothing
    Set wsh = Nothing
    Exit Sub


    ' Error information
ThisMacro_err:
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume ThisMacro_exit


End Sub

[westconn1]

from the code it appears it should save all .xls attachments, but does not in anyway use the attachment file name in column A

depending on the number of emails in outlook folders there may be much better ways than looping all the folder items, you can use the items.restrict method, to limit the number of items to match the subject line

    set sitems = subfolder.items.restrict("[subject]='" & subj & "'")
    For Each Item In sitems
        For Each Atmt In Item.Attachments
            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                FileName = DestFolder & Atmt.FileName
                Atmt.SaveAsFile FileName
                I = I + 1
            End If
        Next Atmt
    Next Item

where subj is an additional parameter to the function, from the calling procedure

ActiveCell.Offset(1, 0).Select

there is no need for this line
also it would be better not to create an instance of outlook for every line in the worksheet, better to just have one instance and use the for all iterations
i believe i would just integrate the function in to the main procedure, though you could open an outlook instance in the main procedure, then pass the outlook subfolder to the function

[abhay_547]

ok. I have made the below changes, but where do i capture the Outlook folder name since its not just one outlook folder we need to loop through different outlook folder and download the attachments and rather than looping through every folder, it's better to look into the folders which are listed in the column C, also how can we make sure that we download only the most recent date attachements from the folders since the mails with same subject are received daily.

Sub Downloademailattachments()

Dim x As Integer
Dim Outlookfolder As String
Dim Subjectline As String
Dim DestFolder As String

NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
Range("A2").Select
    
      For x = 1 To NumRows
Subjectline = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 2)).Value
Outlookfolder = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 3)).Value
DestFolder = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 4)).Value
             
Set sitems = subfolder.items.restrict("[subject]='" & Subjectline & "'")
    For Each Item In sitems
        For Each Atmt In Item.Attachments
            If LCase(Right(Atmt.Filename, Len(ExtString))) = LCase(ExtString) Then
                Filename = DestFolder & Atmt.Filename
                Atmt.SaveAsFile Filename
                I = I + 1
            End If
        Next Atmt
    Next Item

Next
  
End Sub

[westconn1]

i made some changes to your procedure, i also noted that you do not have an outlook application object, so possibly some of the original code was written in outlook, for the outlook variables to be valid would require a reference to outlook, else change the variables to object, i have not tested the code as posted, so may contain some typo or code error, i fixed or changed anything i noticed that did not look right,

Sub Downloademailattachments()

Dim x As Integer
Dim OutlookfolderInInbox As String
Dim Subjectline As String
Dim DestFolder As String
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim MyDocPath As String
    Dim I As Integer
    Dim wsh As Object
    Dim fs As Object

    Set olook = CreateObject("outlook.application")
    Set ns = olook.GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)


NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
' if you want to start at row 2, change to for x = 2 to numrows
For x = 1 To NumRows
    Subjectline = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 2)).Value
    OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 3)).Value
    DestFolder = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 4)).Value
    ExtString = ".xls"
    Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
                 
    Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
    For Each Item In sitems
        For Each Atmt In Item.Attachments
            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                FileName = DestFolder & Atmt.FileName
                'if destfolder does not have a trailing \ then one would need to be appended to the path
                Atmt.SaveAsFile FileName
                I = I + 1
            End If
        Next Atmt
    Next Item
Next x
Set Inbox = Nothing
Set ns = Nothing
' olook.quit  'if required
Set olook = Nothing
End Sub

[abhay_547]

Ok. i had to make a small tweak and it works now, the only thing is that if i have to download the files with multiple extensions at one go then how do i add the same to the code. for e.g. i have *.csv, *.xls, *.txt and *.xml this four extension file type attachments are expected then how can we include the same.

Sub Downloademailattachments()

Dim x As Integer
Dim OutlookfolderInInbox As String
Dim Subjectline As String
Dim DestFolder As String
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim MyDocPath As String
    Dim I As Integer
    Dim wsh As Object
    Dim fs As Object

    Set olook = CreateObject("outlook.application")
    Set ns = olook.GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)


NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
' if you want to start at row 2, change to for x = 2 to numrows
For x = 1 To NumRows
    Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
    OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
    DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
    ExtString = ".xls" 'include other extensions .i.e. *.csv, *.xml, *.txt
    Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
    Filter = "[Unread] = True"
     Set Items = olFolder.Items.Restrict(Filter)
                 
    Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
    For Each Item In sitems
        For Each Atmt In Item.Attachments
            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                FileName = DestFolder & Atmt.FileName
                'if destfolder does not have a trailing \ then one would need to be appended to the path
                Atmt.SaveAsFile FileName
                I = I + 1
            End If
        Next Atmt
    Next Item
Next x
Set Inbox = Nothing
Set ns = Nothing
' olook.quit  'if required
Set olook = Nothing
End Sub]

[westconn1]

change attachment loop like

        For Each Atmt In Item.Attachments
            select case LCase(Right(Atmt.FileName, instr(atmt.filename, ".")))
              case ".xls", ".csv", ".pdf", ".xlsx"
                FileName = DestFolder & Atmt.FileName
                'if destfolder does not have a trailing \ then one would need to be appended to the path
                Atmt.SaveAsFile FileName
                I = I + 1
            End select
        Next Atmt

[abhay_547]

Ok. I have replaced the above piece of code but now it doesn't working and doesn't show any error msg as well. I checked if the destination folder is ending with "\" and it is ending with "\" and everything else is same but it's not working, apart from this i have also tried to declare the extn case as string because i don't want to hardcode the extensions but it didn't work so i have commented it out for now.

Sub Downloademailattachments()

Dim x As Integer
Dim OutlookfolderInInbox As String
Dim Subjectline As String
Dim DestFolder As String
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim MyDocPath As String
    Dim I As Integer
    Dim wsh As Object
    Dim fs As Object

    Set olook = CreateObject("outlook.application")
    Set ns = olook.GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)


NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
' if you want to start at row 2, change to for x = 2 to numrows
For x = 1 To NumRows
    Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
    OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
    DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
    'ExtString = ".xls" 'include other extensions .i.e. *.csv, *.xml, *.txt
    Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
                    
    Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
    For Each Item In sitems
        For Each Atmt In Item.Attachments
            select case LCase(Right(Atmt.FileName, instr(atmt.filename, ".")))
           ' dim fileextn As string
            'fileextn = ThisWorkbook.Sheets("Sheet1").Range("B2").value ' cell B2 will have the text ".xls", ".csv", ".pdf", ".xlsx"
            'case fileextn  
              case ".xls", ".csv", ".pdf", ".xlsx"
                FileName = DestFolder & Atmt.FileName
                'if destfolder does not have a trailing \ then one would need to be appended to the path
                Atmt.SaveAsFile FileName
                I = I + 1
            End select
        Next Atmt
    Next Item
Next x
Set Inbox = Nothing
Set ns = Nothing
' olook.quit  'if required
Set olook = Nothing
End Sub]

[westconn1]

i screwed up the right statement,
decided mid is better anyway

this only partial code to show the changes

    extstring = ".xlsx, .csv, .txt," 'include other extensions .i.e. *.csv, *.xml, *.txt or get from some cell
    Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
                    
    Set sitems = SubFolder.Items.Restrict("[subject]='" & Subjectline & "'")
    For Each Item In sitems
        For Each atmt In Item.Attachments
            fext = Mid(atmt.FileName, InStrRev(atmt.FileName, "."))
            Select Case True
              Case InStr(extstring, fext & ",")
                FileName = DestFolder & atmt.FileName
                atmt.SaveAsFile FileName
                i = i + 1  ' i am not sure what the counter is used for
            End Select
        Next atmt
    Next Item

i changed the select case to use variable, this should now allow a multiple filetype string, needs to have a comma or someother separator character, immediately after each fileextn (including the last)

[abhay_547]

Thanks a lot. it's working now, but the only issue is that if the subject line of the email don't have the date then it may end up downloading previous day attachment. see below 2 examples.

Email subject line 1: Account Balances COB 02/13/2018 (in this case, i have applied a formula in the subject line column (column B) concatenating text and date .i.e. Account balance COB and today minus 1

Email subject line 2: Outstanding Dues (this mail subject line doesn't have the date so in this case its the same every day and if i expect this mail 10am everyday then i will go ahead and run it at 10.05am everyday so if the mail has not yet arrived then it will download previous day mail attachment.

To tackle this issue, i am planning to include a column called Mail Date (Column E) and formulate it with expected date .i.e. if its yesterday COB then today minus 1 and it comes in 2 days then today -2 will take workday to avoid weekend's, so how can we refer the macro to this mail date column

and i want to include also a column at the end (Column F) as Download Status, if the file gets downloaded then it will get populated with the text "File Downloaded Successfully" and if not then it will get populated with the text "Email not found". for error, i was trying to include the below errhandler but believe i am not adding it in the right place, hence its not working. can you advise.

On Error Goto Errhandler

ErrHandler:
     ThisWorkbook.Sheets("Sheet1").cells(x,6).value = "Email Not found"

Sub Downloademailattachments()
Dim x As Integer
Dim OutlookfolderInInbox As String
Dim Subjectline As String
Dim DestFolder As String
Dim MailDate As String
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim MyDocPath As String
    Dim I As Integer
    Dim wsh As Object
    Dim fs As Object

    Set olook = CreateObject("outlook.application")
    Set ns = olook.GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)


NumRows = Range("A5", Range("A5").End(xlDown)).Rows.Count
' if you want to start at row 2, change to for x = 2 to numrows
For x = 5 To NumRows
    Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
    OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
    DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
    MailDate = ThisWorkbook.Sheets("Sheet1").Cells(x, 5)
                       
    extstring = ThisWorkbook.Sheets("Sheet1").Range("B2").Value 'include other extensions .i.e. *.csv, *.xml, *.txt or get from some cell
    Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
                    
    Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
    For Each Item In sitems
    On Error GoTo ErrHandler
        For Each Atmt In Item.Attachments
            fext = Mid(Atmt.FileName, InStrRev(Atmt.FileName, "."))
            Select Case True
              Case InStr(extstring, fext & ",")
                FileName = DestFolder & Atmt.FileName
                Atmt.SaveAsFile FileName
                I = I + 1  ' i am not sure what the counter is used for
            End Select
        Next Atmt
ErrHandler:
     ThisWorkbook.Sheets("Sheet1").Cells(x, 6).Value = "Email Not found"
    Next Item
             
Next x
Set Inbox = Nothing
Set ns = Nothing
' olook.quit  'if required
Set olook = Nothing
End Sub

[westconn1]

you could use some flag to indicate if the mail has already been processed
also message properties have a sentdate you could possibly make use of

[abhay_547]

Ok. thanks. should it be something like below.. also can you help with the error handler. thanks again

Sub Downloademailattachments()
Dim x As Integer
Dim OutlookfolderInInbox As String
Dim Subjectline As String
Dim DestFolder As String
Dim MailDate As String
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim MyDocPath As String
    Dim I As Integer
    Dim wsh As Object
    Dim fs As Object

    Set olook = CreateObject("outlook.application")
    Set ns = olook.GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)


NumRows = Range("A5", Range("A5").End(xlDown)).Rows.Count
' if you want to start at row 2, change to for x = 2 to numrows
For x = 5 To NumRows
    Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
    OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
    DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
    MailDate = ThisWorkbook.Sheets("Sheet1").Cells(x, 5)
                       
    extstring = ThisWorkbook.Sheets("Sheet1").Range("B2").Value 'include other extensions .i.e. *.csv, *.xml, *.txt or get from some cell
    Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
                    
    Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
    For Each Item In sitems
    On Error GoTo ErrHandler
     If item.receivedtime = MailDate then
        For Each Atmt In Item.Attachments
            fext = Mid(Atmt.FileName, InStrRev(Atmt.FileName, "."))
            Select Case True
              Case InStr(extstring, fext & ",")
                FileName = DestFolder & Atmt.FileName
                Atmt.SaveAsFile FileName
                I = I + 1  ' i am not sure what the counter is used for
            End Select
        Next Atmt
ErrHandler:
     ThisWorkbook.Sheets("Sheet1").Cells(x, 6).Value = "Email Not found"
    Next Item
             
Next x
Set Inbox = Nothing
Set ns = Nothing
' olook.quit  'if required
Set olook = Nothing
Else 
End  if

End Sub

[westconn1]

If item.receivedtime = MailDate then

looks like you need an end if somewhere, after next atmt?

errhandler will run every time regardless of whether there is an error, so all rows will show email not found

[abhay_547]

ok. I have updated it for received time. where should i move the errhandler then.

Sub Downloademailattachments()
Dim x As Integer
Dim OutlookfolderInInbox As String
Dim Subjectline As String
Dim DestFolder As String
Dim MailDate As String
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim MyDocPath As String
    Dim I As Integer
    Dim wsh As Object
    Dim fs As Object

    Set olook = CreateObject("outlook.application")
    Set ns = olook.GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)


NumRows = Range("A5", Range("A5").End(xlDown)).Rows.Count
' if you want to start at row 2, change to for x = 2 to numrows
For x = 5 To NumRows
    Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
    OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
    DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
    MailDate = ThisWorkbook.Sheets("Sheet1").Cells(x, 5)
                       
    extstring = ThisWorkbook.Sheets("Sheet1").Range("B2").Value 'include other extensions .i.e. *.csv, *.xml, *.txt or get from some cell
    Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
                    
    Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
    For Each Item In sitems
    On Error GoTo ErrHandler
     If item.receivedtime = MailDate then
        For Each Atmt In Item.Attachments
            fext = Mid(Atmt.FileName, InStrRev(Atmt.FileName, "."))
            Select Case True
              Case InStr(extstring, fext & ",")
                FileName = DestFolder & Atmt.FileName
                Atmt.SaveAsFile FileName
                I = I + 1  ' i am not sure what the counter is used for
            End Select
        Next Atmt

Else 
End  if

ErrHandler:
     ThisWorkbook.Sheets("Sheet1").Cells(x, 6).Value = "Email Not found"
    Next Item
             
Next x
Set Inbox = Nothing
Set ns = Nothing
' olook.quit  'if required
Set olook = Nothing


End Sub

[westconn1]

think in this case i would use in-line error handling, for each email

Sub Downloademailattachments()
Dim x As Integer
Dim OutlookfolderInInbox As String
Dim Subjectline As String
Dim DestFolder As String
Dim MailDate As String
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim MyDocPath As String
    Dim I As Integer
    Dim wsh As Object
    Dim fs As Object

    Set olook = CreateObject("outlook.application")
    Set ns = olook.GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)


NumRows = Range("A5", Range("A5").End(xlDown)).Rows.Count
' if you want to start at row 2, change to for x = 2 to numrows
On Error resume next
For x = 5 To NumRows
    Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
    OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
    DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
    MailDate = ThisWorkbook.Sheets("Sheet1").Cells(x, 5)
                       
    extstring = ThisWorkbook.Sheets("Sheet1").Range("B2").Value 'include other extensions .i.e. *.csv, *.xml, *.txt or get from some cell
    Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
                    
    Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
    For Each Item In sitems

     If item.receivedtime = MailDate then
        For Each Atmt In Item.Attachments
            fext = Mid(Atmt.FileName, InStrRev(Atmt.FileName, "."))
            Select Case True
              Case InStr(extstring, fext & ",")
                FileName = DestFolder & Atmt.FileName
                Atmt.SaveAsFile FileName
                I = I + 1  ' i am not sure what the counter is used for
            End Select
        Next Atmt

Else 
End  if

   if not err.number = 0 then
     ThisWorkbook.Sheets("Sheet1").Cells(x, 6).Value = "Some error occurred"
     err.clear
   end if
    Next Item
             
Next x
Set Inbox = Nothing
Set ns = Nothing
' olook.quit  'if required
Set olook = Nothing
End Sub

this should work ok for any error saving the attachments, and allows the code to continue for next rows, but does nothing for other parts of the code so i moved the on error forward to encompass finding the outlook folder as well, some separate error handler may be good for the setting the outlook objects as without them nothing will work