Saving attachments, while deleting items, only works half of the time or not on all messages

Question

I want to save all attachments from a specific Outlook folder (MyFolder) to a desktop folder (Test). It seems to only work half of the time or not on all messages.

My first thought would be that the macro is quicker than Windows saving the files causing it to "skip" Outlook messages.

The code, partially from Ron de Bruin's website.

Option Explicit

Sub SaveAttachmentsFromMyFolder()
'Arg 1 = Folder name of folder inside your Inbox
'Arg 2 = File extension, "" is every file
'Arg 3 = Save folder, "C:\Users\Ron\test" or ""
'        If you use "" it will create a date/time stamped folder for you in your "Documents" folder
'        Note: If you use this "C:\Users\Ron\test" the folder must exist.

    SaveEmailAttachmentsToFolder "MyFolder", "C:\Documents\Test"
    
End Sub

Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox 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 = ""

        Set fs = CreateObject("Scripting.FileSystemObject")

    If Not fs.FolderExists(DestFolder) Then
        fs.CreateFolder DestFolder
    End If


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

    ' Check each message for attachments and extensions
    '   Check flagstatus
    For Each Item In SubFolder.Items
        If Item.FlagStatus = olFlagComplete Then
            Item.Delete
            ' build in a wait till file actually deleted?
        Else

                For Each Atmt In Item.Attachments
                '   missing code: extract date from file name, check if folder exists and create if not, save attachment in date-folder
                    FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
                    Atmt.SaveAsFile FileName
                    ' build in a wait till file actually saved?
                    I = I + 1
                Next Atmt
            Item.FlagStatus = olFlagComplete
            Item.Save
            ' build in a wait till file actually saved?
        End If
    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

Answer 1

Here is code I use to save attachments from selected e-mails. You should be able to alter the For loop to loop through a folder instead easily enough.

Public Sub SaveAttachmentsSelectedEmails()
    Dim olItem As Outlook.MailItem
    Dim olSelection As Outlook.Selection: Set olSelection = ActiveExplorer.Selection
    Dim FilePath As String: FilePath = Environ("USERPROFILE") & "\Documents\Documents\Attachments"

    If Dir(FilePath, vbDirectory) = "" Then
        Debug.Print "Save folder does not exist"
        Exit Sub
    End If

    For Each olItem In olSelection
        SaveAttachments olItem, FilePath, RemoveAttachments:=False
    Next olItem
End Sub

Private Function SaveAttachments(ByVal Item As Object, FilePath As String, _
    Optional Prefix As String = "", _
    Optional FileExtensions As String = "*", _
    Optional Delimiter As String = ",", _
    Optional RemoveAttachments As Boolean = False, _
    Optional OverwriteFiles As Boolean = False) As Boolean

    On Error GoTo ExitFunction

    Dim i As Long, j As Long, FileName As String, Flag As Boolean
    Dim Extensions() As String: Extensions = Split(FileExtensions, Delimiter)
    If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"

    For j = LBound(Extensions) To UBound(Extensions)
        With Item.Attachments
            If .Count > 0 Then
                For i = .Count To 1 Step -1
                    FileName = FilePath & Prefix & .Item(i).FileName
                    Flag = IIf(LCase(Right(FileName, Len(Extensions(j)))) = LCase(Extensions(j)), True, False)
                    Flag = IIf(FileExtensions = "*" Or Flag = True, True, False)
                    If Flag = True Then
                        If Dir(FileName) = "" Or OverwriteFiles = True Then
                            .Item(i).SaveAsFile FileName
                        Else
                            Debug.Print FileName & " already exists"
                            Flag = False
                        End If
                    End If
                    If RemoveAttachments = True And Dir(FileName) <> "" And Flag = True Then .Item(i).Delete
                Next i
            End If
        End With
    Next j
    SaveAttachments = True

ExitFunction:
End Function