仅保存收件箱中由特定发件人在特定日期发送的那些 Outlook 电子邮件附件

Question

嗨，我的 OL 收件箱中有超过 3500 封电子邮件。 我的条件是。

1. 我想根据我的要求使用 Outlook VBA 保存来自某些特定发件人的所有附件以用于某些特定日期。

Sub Save_OutLook_Attachments_To_Folder()
Dim App As Outlook.Application
Dim MyFolder As Outlook.MAPIFolder
Dim NS As Outlook.Namespace
Dim Msg As Outlook.MailItem
Dim Attachments As Outlook.Attachments
Dim Items As Outlook.Items
Dim i As Long
Dim lngCount As Long
Dim File As String
Dim FolderPath As String
Dim Sender_Email As String ''''

Sender_Email = "someone@somewhere.com" '''''''objMail.SenderEmailAddress  ''''''
FolderPath = ThisWorkbook.Path & "\" & "\Outlook Attachments\" '''Change the Destination Folder Path
Set App = New Outlook.Application
Set NS = App.GetNamespace("MAPI")
Set MyFolder = NS.GetDefaultFolder(olFolderInbox) ''''''''''''
Set Items = MyFolder.Items
Items.Sort Property:="[ReceivedTime]", Descending:=True
FolderPath = FolderPath
For Each Msg In MyFolder.Items
If Msg.SenderEmailAddress = Sender_Email Then '''''
Set Attachments = Msg.Attachments
lngCount = Attachments.Count
End If
Next
If lngCount > 0 Then
For i = lngCount To 1 Step -1
File = Attachments.Item(i).FileName
File = FolderPath & File
Attachments.Item(i).SaveAsFile File
Next
End If
End Sub

如果有人能在这种情况下帮助我，将不胜感激。

提前致谢。

Answer 1

而不是遍历文件夹中的所有项目并检查与发件人相关的属性：

For Each Msg In MyFolder.Items
  If Msg.SenderEmailAddress = Sender_Email Then '''''

使用Items类的Find / FindNext或Restrict方法。 在这种情况下，您将获得与指定的搜索条件相对应的项目集合。 您可以在以下文章中阅读有关这些方法的更多信息：

• 如何：使用 Find 和 FindNext 方法从文件夹中检索 Outlook 邮件项目（C#、VB.NET）
• 如何：使用限制方法从文件夹中检索 Outlook 邮件项目

尝试使用以下搜索条件：

criteria = "@SQL=" & Chr(34) & "urn:schemas:httpmail:senderemail" & Chr(34) & " LIKE '%" & Sender_Email & "%'"

有关详细信息，请参阅使用字符串比较过滤项目。

---

请注意，您可以在搜索字符串中使用逻辑 AND 运算符，您可以在其中组合多个条件。 要搜索特定日期的项目，您可以过滤urn:schemas:httpmail:datereceived属性。 在以下文章中找到示例代码：

• 如何：使用 Find 和 FindNext 方法检索 Outlook 日历项目
• 如何：在 Outlook 中使用 Restrict 方法获取日历项目

Answer 2

这是我用来保存我选择的电子邮件中的附件的代码。 您可能可以适应您的要求或在需要时手动过滤和选择电子邮件。

Public Sub SaveAttachmentsSelectedEmails()
    Dim olItem As Outlook.MailItem
    Dim olSelection As Outlook.Selection: Set olSelection = ActiveExplorer.Selection
    Dim FilePath As String: FilePath = Environ("USERPROFILE") & "\Documents\Documents\Attachments"

    If Dir(FilePath, vbDirectory) = "" Then
        Debug.Print "Save folder does not exist"
        Exit Sub
    End If

    For Each olItem In olSelection
        SaveAttachments olItem, FilePath, RemoveAttachments:=False
    Next olItem
End Sub

Private Function SaveAttachments(ByVal Item As Object, FilePath As String, _
    Optional Prefix As String = "", _
    Optional FileExtensions As String = "*", _
    Optional Delimiter As String = ",", _
    Optional RemoveAttachments As Boolean = False, _
    Optional OverwriteFiles As Boolean = False) As Boolean

    On Error GoTo ExitFunction

    Dim i As Long, j As Long, FileName As String, Flag As Boolean
    Dim Extensions() As String: Extensions = Split(FileExtensions, Delimiter)
    If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"

    For j = LBound(Extensions) To UBound(Extensions)
        With Item.Attachments
            If .Count > 0 Then
                For i = .Count To 1 Step -1
                    FileName = FilePath & Prefix & .Item(i).FileName
                    Flag = IIf(LCase(Right(FileName, Len(Extensions(j)))) = LCase(Extensions(j)), True, False)
                    Flag = IIf(FileExtensions = "*" Or Flag = True, True, False)
                    If Flag = True Then
                        If Dir(FileName) = "" Or OverwriteFiles = True Then
                            .Item(i).SaveAsFile FileName
                        Else
                            Debug.Print FileName & " already exists"
                            Flag = False
                        End If
                    End If
                    If RemoveAttachments = True And Dir(FileName) <> "" And Flag = True Then .Item(i).Delete
                Next i
            End If
        End With
    Next j
    SaveAttachments = True

ExitFunction:
End Function