Question

我在Outlook中有一个启用了按钮的宏，可以查看我有权访问的共享收件箱，在每个邮件项目中找到Excel附件，然后将它们提取到网络上的某个位置，创建一个文件夹名称，其中包含主题的详细信息。电子邮件，如果它尚不存在。当我第一次运行宏大约3个月前，我没有遇到任何错误消息。但是，今天再次运行它会出现以下错误消息： '无法保存附件。您没有相应的权限来执行此操作' 如果我将附件保存到我想要的网络位置，我就没有问题。我在代码中使用了msgbox提示符告诉我在保存之前附件的完整路径是什么。我不确定这是否意味着什么，但atmt.pathname只会显示一个空白的消息框。可能是什么问题？似乎我试图保存的附件实际上并不存在。我有Outlook 2007与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

Answer 1

您是否将文件属性设置为vbNormal？有可能是隐藏或只读的另一种模式....

Answer 2

在SaveAsFile(Path)中指定路径时

该路径需要包含要保存的文件的名称，因此，如果要使用相同的名称保存文件，请使用附件项目的.DisplayName属性。

宏错误'无法保存附件。没有适当的许可'

2 个答案: