1
我在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