VBA Outlook Email Attachment Save Permissions-CodePudding

This script is suppose to loop through my outlook folder inbox-> Work Request Then for each mail item in that folder download each attachment and save if to a file location.

Code seems to work fine in finding the folder and the correct emails however it is giving me an error message on the following line of code saying "Run-Time Error '-2147024891(80070005) Cannot save the attachment. You don't have the appropriate permissions to perform this operation."

I have tried multiple save location including our external cloud drive and my personal desktop. Currently the code is saving to my desktop and still says I do not have appropriate permissions to save. Any help would be greatly appreciated.

olAtt.SaveAsFile ("C:\Users\John Smith\Desktop\WOR Email Download")

The rest of the script is depicted below.

Option Explicit


Sub Download_Outlook_Attachemtns()



Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olItem As Object
Dim MailItem As Outlook.MailItem
Dim olAtt As Outlook.Attachment
Dim FileLocation As String

Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")


'single folder link to hidden sheet folders([admin].[Mailbox].text)
Set olFolder = olNS.Folders("[email protected]")
Set olFolder = olFolder.Folders("Inbox")
Set olFolder = olFolder.Folders("Work Requests")




For Each olItem In olFolder.Items

    If olItem.Class = olMail Then
        Set MailItem = olItem
            'Debug.Print MailItem.Subject



    For Each olAtt In MailItem.Attachments
        If MailItem.ReceivedTime > ThisWorkbook.Worksheets("Email_Info").Range("C6").Value Then
    
            olAtt.SaveAsFile ("C:\Users\John Smith\Desktop\WOR Email Download")
            'olAtt.SaveAs Filename:=Application.GetSaveAsFilename
        End If
    Next olAtt


     End If
Next olItem




'Set olFolder = Nothing
'Set olNS = Nothing


End Sub

CodePudding user response：

You must include the file name besides the folder name. Currently, you are telling Outlook to save to a file conflicting with an existing folder name ("WOR Email Download"), hence the "no access" error - the file cannot be created since its name conflicts with an existing folder name. Change your code to

if olAtt.Type = olByValue Then
  olAtt.SaveAsFile "C:\Users\John Smith\Desktop\WOR Email Download\" & olAtt.FileName
End If

CodePudding user response：

First of all, instead of iterating over all items in the folder:

For Each olItem In olFolder.Items

    If olItem.Class = olMail Then
        Set MailItem = olItem

You can find all items with attachments in the folder and iterate over them only. The Find/FindNext or Restrict methods of the Items class do the magic. Read more about these methods in the articles I wrote for the technical blog:

For example, you can use the following search criteria (VBA syntax):

Filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:hasattachment" & Chr(34) & "=1"

Also it makes sense to optimize the code by changing the order of conditions:

For Each olAtt In MailItem.Attachments
        If MailItem.ReceivedTime > ThisWorkbook.Worksheets("Email_Info").Range("C6").Value Then

Instead of checking the received time of the email for each attachment you can check it once for the email before iterating over attached files or, better yet, you may include another condition to the search criteria by using the logical AND operator in the search string.

Finally, you may try to check the Attachment.Type property value before trying to save anything to the disk. The property returns an OlAttachmentType constant indicating the type of the specified object.