使用 Excel VBA 从 Outlook 收件箱中的最新电子邮件下载 Excel 文件

Question

我每周都会收到一次Excel附件(.xlsm(形式的报告。我需要访问最新的电子邮件，然后在其中下载Excel附件并将其保存到桌面上的特定路径。

邮箱称为"ACBS MIS 报告"，附件始终称为"AMLS 的 ACBS LC 报告 - 月份 DD"。它将始终是我感兴趣的最新电子邮件(在邮箱顶部(。

此代码返回代码底部"GetAttachments_err"下编写的错误消息。

Sub GetAttachments()
' This Outlook macro checks a the Outlook Inbox for messages
' with attached files (of any type) and saves them to disk.
' NOTE: make sure the specified save folder exists before
' running the macro.
On Error GoTo GetAttachments_err
'Declare Variables
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
'Check Inbox for messages and exit if none found
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In Inbox.Items
'Save any attachments found
For Each Atmt In Item.Attachments
' This path must exist! Change folder name as necessary.
FileName = "C:UsersjalangerDesktopLetters of CreditMacro WorkTest" & Atmt.DisplayName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
' Show summary message
If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:Email Attachments folder." _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
'Clear memory
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
'Handle errors
GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Sub

Answer 1

编辑 宏已编辑为从 Excel 而不是 Outlook 运行。 它使用早期绑定，因此您需要设置对 Outlook 对象库(VBE>>工具>>引用>>的引用，然后选择Microsoft Outlook 对象库(。

以下宏首先根据指定的发件人姓名筛选收件箱中的项目，然后按接收时间和降序对它们进行排序，然后从筛选和排序列表中获取第一个项目。 最后，它保存指定的附件(如果存在(。 请注意，如果已存在与附件同名的文件，则现有文件将被覆盖。 更改保存到文件夹、发件人姓名和附件名称(如果指示(。

Option Explicit
Sub GetLatestReport()
'Set a reference to Outlook's object library (Visual Basic >> Tools >> References >> check/select Microsoft Outlook Object Library)
Dim outlookApp              As Outlook.Application
Dim outlookInbox            As Outlook.MAPIFolder
Dim outlookRestrictItems    As Outlook.Items
Dim outlookLatestItem       As Outlook.MailItem
Dim outlookAttachment       As Outlook.Attachment
Dim attachmentFound         As Boolean
Const saveToFolder          As String = "C:UsersDomenicDesktop" 'change the save to folder accordingly
Const senderName            As String = "SenderName" 'change the sender name accordingly
Const attachmentName        As String = "AttachmentName" 'change the attachment name accordingly
'Create an instance of Outlook
Set outlookApp = New Outlook.Application
'Get the inbox from Outlook
Set outlookInbox = outlookApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
'Filter the items from the inbox based on the sender
Set outlookRestrictItems = outlookInbox.Items.Restrict("[SenderName] = '" & senderName & "'")
'Check whether any items were found
If outlookRestrictItems.Count = 0 Then
MsgBox "No items were found from " & senderName & "!", vbExclamation
Exit Sub
End If
'Sort the filtered items by received time and in descending order
outlookRestrictItems.Sort Property:="[ReceivedTime]", Descending:=True
'Get the latest item from the filtered and sorted items
Set outlookLatestItem = outlookRestrictItems(1)
'Loop through each attachment from the latest item until specified file is found
attachmentFound = False
For Each outlookAttachment In outlookLatestItem.Attachments
If Left(UCase(outlookAttachment.Filename), Len(attachmentName)) = UCase(attachmentName) Then
outlookAttachment.SaveAsFile saveToFolder & "" & outlookAttachment.DisplayName
attachmentFound = True
Exit For
End If
Next outlookAttachment
If attachmentFound Then
MsgBox "The attachment was found and saved to '" & saveToFolder & "'!", vbInformation
Else
MsgBox "No attachment was found!", vbExclamation
End If
End Sub