Question

我正在尝试执行以下操作：

搜索未读电子邮件
打开具有特定关键字的
从电子邮件中下载附件（如果我也可以过滤附件，那就太好了）
将电子邮件标记为已读。

这就是我正在使用的。

Sub DownloadAttachmentFirstUnreadEmail()
    Dim oOlAp As Object, oOlns As Object, oOlInb As Object
    Dim oOlItm As Object, oOlAtch As Object
    Dim strFilter As String

    '~~> 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)

    '~~> Check if there are any actual unread emails
    If oOlInb.Items.Restrict("[UnRead] = True").count = 0 Then
        MsgBox "NO Unread Email In Inbox"
        Exit Sub
    End If

    '~~> Extract the attachment from the 1st unread email
    For Each oOlItm In oOlInb.Items.Restrict("[UnRead] = True")

        'The above loop begins to read everything that is unread.

        'This is the part that gets tricky
        'Here we need to begin filtering subject headline
        'The line below defines what we are filtering

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

        If filteredItems.count = 0 Then
            Debug.Print "No emails found"
            Found = False
        Else

            '~~> Check if the email actually has an attachment
            If oOlItm.Attachments.count <> 0 Then
                For Each oOlAtch In oOlItm.Attachments
                    '~~> Download the attachment
                    oOlAtch.SaveAsFile NewFileName & oOlAtch.FileName
                    Exit For
                Next
            Else
                MsgBox "The First item doesn't have an attachment"
            End If

        End If

       '~~> Mark 1st unread email as read
        oOlItm.UnRead = False
        DoEvents
        oOlItm.Save
        Exit For
    Next
End Sub

Answer 1

使用代码的结构方式，如果您在第一个过滤器中的每个未读项目上使用Instr，它可能会有效。

第二个过滤器效率更高。

Sub FilerBySubjectUnreadEmail()

    Dim oOlAp As Object
    Dim oOlns As Object
    Dim oOlInb As Object

    Dim oOlItm As Object
    Dim oOlAtch As Object
    Dim strFilter As String

    Dim objUnreadItems As Items
    Dim filteredItems As Items
    Dim i As Long

    '~~> Get Outlook instance
    On Error Resume Next ' You can use this as there is a purpose
    Set oOlAp = GetObject(, "Outlook.application")
    On Error GoTo 0  ' One line from On Error Resume Next. If say five or more lines you are fired.

    If oOlAp Is Nothing Then Set oOlAp = CreateObject("Outlook.application")

    Set oOlns = oOlAp.GetNamespace("MAPI")
    Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)

    Set objUnreadItems = oOlInb.Items.Restrict("[UnRead] = True")

    '~~> Check if there are unread emails
    If objUnreadItems.count = 0 Then
        MsgBox "NO Unread Email In Inbox"
        Exit Sub
    End If

    ' Change sketch to what you are looking for
    strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%sketch%'"

    Set filteredItems = objUnreadItems.Restrict(strFilter)

    If filteredItems.count = 0 Then
        Debug.Print "No emails found with applicable subject"
        Exit Sub

    Else

        For i = filteredItems.count To 1 Step -1

            'Debug.Print i & " - " & filteredItems.count

            '~~> Check if the email actually has an attachment
            Set oOlItm = filteredItems(i)

            If oOlItm.Attachments.count <> 0 Then
                For Each oOlAtch In oOlItm.Attachments
                    Debug.Print oOlItm.Subject
                    Debug.Print oOlAtch.DisplayName
                Next

                '~~> Mark email as read
                filteredItems(i).UnRead = False
                DoEvents

                ' Safest to save the item
                '  in case it is needed
                '  but not necessary with Read/Unread
                ' oOlItm.Save

        Else
            MsgBox oOlItm.Subject & " doesn't have an attachment."

        End If

    Next

    End If

ExitRoutine:
    Set oOlAp = Nothing
    Set oOlns = Nothing
    Set oOlInb = Nothing

    Set oOlItm = Nothing
    Set oOlAtch = Nothing

    Set objUnreadItems = Nothing
    Set filteredItems = Nothing

End Sub

根据主题过滤Outlook电子邮件，然后下载附件

1 个答案: