Reputation: 1
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?
Upvotes: 0
Views: 66
Reputation: 7774
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
Upvotes: 1