Question

我有一个很棒的代码可以从我收件箱中的上一封电子邮件中下载附件（xlsb），但我有两个问题：

1 - 我需要更改此内容，以便首先查找第一封电子邮件（最新）。

2 - 它应该只查找包含以下单词的主题的电子邮件：DOCUMENT_APP（名称各不相同，但它始终包含document_app，因此需要使用通配符）

这是我的代码，它会查找最早的电子邮件并保存xlsb附件文件（忽略主题）：

Sub DownloadAttachmentFirstEmail()


 Application.StatusBar = False
 Application.StatusBar = "Downloading email"
Application.DisplayAlerts = False
    Dim oOlAp As Object, oOlns As Object, oOlInb As Object
    Dim oOlItm As Object, oOlAtch As Object



    '~~> New File Name for the attachment
    Dim NewFileName As String
    NewFileName = AttachmentPath & Format(Date, "DD-MM-YYYY") & "-"

    '~~> Get Outlook instance
    Set oOlAp = GetObject(, "Outlook.application")
    Set oOlns = oOlAp.GetNamespace("MAPI")
    Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)

    For Each oOlItm In oOlInb.Items

          '~~> Check if the email actually has an attachment
        If oOlItm.Attachments.Count <> 0 Then
             For Each oOlAtch In oOlItm.Attachments



             If Right(oOlAtch.Filename, 4) = "xlsb" Then

   oOlAtch.SaveAsFile NewFileName & oOlAtch.Filename

            MsgBox "SAVED"

            Exit Sub


            End If



            Next

        Else

        End If

    Next


   ' DO SOMETHING

 End Sub

对于问题n 2，我尝试更改此行：

For Each oOlItm In oOlInb.Items

为此：

For Each oOlItm In oOlInb.Items.Restrict("[Subject] = ""*DOCUMENT_APP*""")

但它没有做任何事情，它没有给出错误，它只是退出sub

Answer 1

niton提供了一个有用的链接，我可以通过使用：

完成它

  strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%sketch%'"

从包含特定主题的最新电子邮件下载附件 - VBA Excel

1 个答案: