CODEWITHSUNDEEP
vbapermissionsoutlooksaveattachment
user3173215
user3173215

Reputation: 11

Macro error 'Cannot save the attachment. Don't have appropriate permission'

I have a button enabled macro in Outlook that looks through a shared inbox I have access to, finds Excel attachments in each mail item and then extracts them to a location on the network, creating a folder name with details of the subject of the email if it does not already exist. When I first ran the macro about 3 months ago, I didn't encounter any error messages. However, running it again today brought up the following error message: 'Cannot save the attachment. You don't have the appropriate permission to perform this operation' If I save the attachment to the location I want on the network, I have no problem doing so. I used a msgbox prompt in the code to tell me what the attachment fullpath is before saving it. I'm not sure if this means anything but the atmt.pathname just brings up a blank messagebox. What might be the issue? it seems as if the attachment I'm trying to save isn't actually there. I have Outlook 2007 with Microsoft Exchange.

 ' Declare variables
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim myDestFolder As Outlook.MAPIFolder
Dim Item As Object

Dim Atmt As Attachment
Dim filename As String
Dim i As Integer
Dim iLoop As Integer
Dim ext As String
Dim Items As Outlook.Items

Dim counter
Dim Countofiloop, NumberOfInboxItems
Dim CategoryNameDetected As Boolean
Dim moveEmail As Boolean
Dim EmailSubject As String
Dim SiteNames As String
Dim targetRoute As String
Dim targetPath As String

' -------------------------- HERE SETS THE ROUTE TARGET PATH --------------------
targetRoute = "FolderPath\"
' -------------------------------------------------------------------------------
Dim Progress
Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders("Shared").Folders("Inbox")
Set Item = Inbox.Items
' Before the loop starts, set the vars
 ' Check Inbox for messages and exit if none found
If Inbox.Items.count = 0 Then
MsgBox "There are no messages to scan in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If

 ' Check each message for attachments
 NumberOfInboxItems = Inbox.Items.count
 TotalInboxItems = NumberOfInboxItems
 counter = 0
'========================== L O O P   S T A R T S   H E R E ===============
    For i = 1 To NumberOfInboxItems
    ' assign email subject to as string
    Set Item = Inbox.Items.Item(i)
    EmailSubject = Item.Subject
    counter = counter + 1
    KPISorterForm.ListBox1.AddItem "Examining email " & counter & " out of " & Inbox.Items.count & " " & EmailSubject
    DoEvents
    ' WHAT IS IT???----SET THE FILE PATH----------------------------------------
    ' does it have four digits in the subject line at the beginning?
        If IsNumeric(Left(EmailSubject, 4)) = True And InStr(1, EmailSubject, "for") > 0 Then
        SiteNames = Left(EmailSubject, InStr(1, EmailSubject, "for") - 2)

' Trim the string if ending with a space character
        Do Until Not Right(SiteNames, 1) = " "
        SiteNames = Left(SiteNames, Len(SiteNames) - 1)
        Loop

        SiteNames = Replace(SiteNames, "  ", "")
    ' Save the attachment to specified location
            For Each Atmt In Item.Attachments

        ' This filename path must exist! Change folder name as necessary.
        ' get here the extension

            ext = Atmt.filename
            ext = Right(ext, Len(ext) - InStrRev(ext, ".") + 1)
                If Left(ext, 3) = ".xl" Then
                targetPath = targetRoute & SiteNames

                    ' SAVE ATTACHMENT
                    If testDir(targetPath) = False Then
                    KPISorterForm.ListBox1.AddItem "Creating directory " & targetPath
                    DoEvents
                    MkDir targetPath

                   End If
MsgBox Atmt.PathName
                Atmt.SaveAsFile targetPath & "\" & SiteNames & ext
                KPISorterForm.ListBox1.AddItem "Saving Item " & targetPath & "\" & SiteNames & ext
                DoEvents
                AttachmentsSaved = AttachmentsSaved + 1
                moveEmail = True

                End If

            Next Atmt
        End If

    KPISorterForm.ListBox1.ListIndex = KPISorterForm.ListBox1.ListCount - 1

    Next i

 ' Clear memory
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Set appOl = Nothing
Set myDestFolder = Nothing

HomeUserFormOutlook.ProgressFrame.Visible = False
HomeUserFormOutlook.ProgressBar.Width = 0
HomeUserFormOutlook.ProgressBar.Visible = False
DoEvents

Upvotes: 1

Views: 5609

Answers (2)

ismail
ismail

Reputation: 51

When you specify the path in SaveAsFile(Path)

The path needs to include the name of the file that you are saving, so if you want the file to be saved with the same name use the .DisplayName property of the attachment item.

Upvotes: 2

meer2kat
meer2kat

Reputation: 241

Did you set your file attributes to vbNormal? Chances are it's in another mode like hidden or read-only....

Upvotes: 2

Related Questions