Outlook macro missing out documents

Question

I built a macro for Outlook to save pdf attachments from all emails in a certain folder.

Sub SavePdfAttachments()
    Dim olApp           As Object
    Dim olNS            As Object
    Dim olFolder        As Object
    Dim olItems         As Object
    Dim olItem          As Object
    Dim olAtt           As Object
    Dim sSaveToFolder   As String
    Dim Ans             As Long
    
    sSaveToFolder = "C:\Users\admin\Documents\Invoices\" 'change the destination folder accordingly
    
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.Folders("******@***********.co.uk").Folders("Invoices") 'change the source folder accordingly
    Set olItems = olFolder.Items
    
    For Each olItem In olItems
        If olItem.Attachments.Count > 0 Then
            For Each olAtt In olItem.Attachments
                If Right(olAtt.FileName, 4) = ".pdf" Then
                    If Len(Dir(sSaveToFolder & olAtt.FileName)) = 0 Then
                        olAtt.SaveAsFile sSaveToFolder & olAtt.FileName
                        olItem.Save
                    Else
                        Ans = MsgBox(olAtt.FileName & " already exists.  Overwrite file?", vbQuestion + vbYesNo)
                        If Ans = vbYes Then
                            olAtt.SaveAsFile sSaveToFolder & olAtt.FileName
                            olItem.Save
                        End If
                    End If
                End If
            Next olAtt
        End If
    Next olItem
    
    Set olApp = Nothing
    Set olNS = Nothing
    Set olFolder = Nothing
    Set olItems = Nothing
    Set olItem = Nothing
    Set olAtt = Nothing
    
End Sub

I run the macro and expect all pdf attachments to be downloaded to the specified folder.

Most of them get downloaded, but some get skipped out...

What have I done wrong?

Answer 1

The PDF Server that is responsible for downloading the files is probably hanging on some of the files being downloaded. My solution stores the attachments in a dictionary and then will try and redownload it (pausing 200ms between files), if the file doesn't exists.

#If VBA7 Then
 Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
 Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds as Long) 'For 32 Bit Systems
#End If

Sub SavePdfAttachments()
    Dim olApp           As Object
    Dim olNS            As Object
    Dim olFolder        As Object
    Dim olItems         As Object
    Dim olItem          As Object
    Dim olAtt           As Object
    Dim sSaveToFolder   As String
    Dim Ans             As Long
    
    sSaveToFolder = "C:\Users\admin\Documents\Invoices\" 'change the destination folder accordingly
    
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.Folders("******@***********.co.uk").Folders("Invoices") 'change the source folder accordingly
    Set olItems = olFolder.Items
    Dim Attachments As Object
    Set Attachments = CreateObject("Scripting.Dictionary")
    
    For Each olItem In olItems
        If olItem.Attachments.Count > 0 Then
            
            For Each olAtt In olItem.Attachments
                If Right(olAtt.Filename, 4) = ".pdf" Then
                    Rem Store the Attachment
                    Attachments.Add Key:=sSaveToFolder & olAtt.Filename, Item:=olAtt
                    
                    If Len(Dir(sSaveToFolder & olAtt.Filename)) = 0 Then
                        olAtt.SaveAsFile sSaveToFolder & olAtt.Filename
                        olItem.Save
                    Else
                        Ans = MsgBox(olAtt.Filename & " already exists.  Overwrite file?", vbQuestion + vbYesNo)
                        If Ans = vbYes Then
                            olAtt.SaveAsFile sSaveToFolder & olAtt.Filename
                            olItem.Save
                        End If
                    End If
                End If
            Next olAtt
        End If
    Next olItem
    DownloadMissingPDFs Attachments, 5
    
    Set olApp = Nothing
    Set olNS = Nothing
    Set olFolder = Nothing
    Set olItems = Nothing
    Set olItem = Nothing
    Set olAtt = Nothing
    
End Sub

Sub DownloadMissingPDFs(Attachments As Collection, Optional NumberOfAttempts As Long)
    Const NumberOfSecondsToSleep As Long = 200
    If NumberOfAttempts < 1 And PDFMailItems.Count > 0 Then
        Debug.Print "Files not saved:"
        Debug.Print Join(Attachments.Keys, vbNewLine)
        Exit Sub
    End If
    
    NumberOfAttempts = NumberOfAttempts - 1
    
    Dim Attachment As Object
    Dim FilePath As Variant
    
    For Each FilePath In Attachments
        Set Attachment = Attachments(FilePath)
        If Len(FilePath) = 0 Then
            Attachment.SaveAsFile sSaveToFolder & Attachment.Filename
            Attachment.Save
            Sleep NumberOfSecondsToSleep
        Else
            Attachments.Remove FilePath
        End If
    Next
    
    DownloadMissingPDFs Attachments, NumberOfAttempts
End Sub   End Sub