vba - Outlook 2016 - 按接收日期/发送日期对受限项目进行排序并选择最新的电子邮件

Question

使用 Outlook 2016，我尝试查找发送到特定电子邮件地址或从特定电子邮件地址接收的最新电子邮件，并将其副本保存到特定文件夹。

我已经开发了一些代码，但我认为我在排序和选择正确的受限项目时遇到了问题。一旦他们按日期排序，代码就不会选择最新的电子邮件。如果多次运行代码，它会始终返回相同的电子邮件，但绝对不会返回最新的电子邮件。

下面是我创建的函数。希望有人能够提供帮助。提前致谢。

Sub Get_The_Emails(intTarget As Integer)
    Dim oInboxFolder As Outlook.folder, oSentFolder As Outlook.folder
    Dim tFolder As Outlook.folder, sFolder As Outlook.folder
    Dim oNS As Outlook.NameSpace
    Dim oInboxItems As Outlook.Items, oSentItems As Outlook.Items, colItems As Outlook.Items
    Dim oFilteredInboxItems As Outlook.Items, oFilteredSentItems As Outlook.Items, oFilteredItems As Outlook.Items
    Dim oReceivedItem As Outlook.MailItem, oSentItem As Outlook.MailItem, oItem As Outlook.MailItem
    Dim strFolder As String
    Dim strSentFilter As String, strReceivedFilter As String
    Dim intFolder As Integer, intMode As Integer, intSource As Integer
    Dim theReceivedTime As Date, theSentTime As Date
    Dim inputFile As String
    Dim inputNum As Integer, i As Integer
    Dim strEnviro As String, strContent As String
    Dim varList As Variant


    strEnviro = CStr(Environ("USERPROFILE"))
    inputFile = strEnviro & "\Desktop\Email-List.txt"

    If Dir(inputFile, vbDirectory) = "" Then
        MsgBox "File: " & inputFile & " could not be found", vbCritical, "Error"
        Exit Sub
    Else
        CleanList inputFile
        DoEvents
    End If

    inputNum = FreeFile
    Open inputFile For Input As inputNum
        strContent = Input(LOF(inputNum), inputNum)
    Close inputNum

    If Len(strContent) < 6 Then
        MsgBox "Invalid email address list", vbCritical, "Error"
        Exit Sub
    Else
        varList = Split(strContent, vbNewLine)
    End If

    Set oNS = Application.GetNamespace("MAPI")
    Set oInboxFolder = oNS.Session.GetDefaultFolder(olFolderInbox)
    Set oInboxItems = oInboxFolder.Items
    Set oSentFolder = oNS.Session.GetDefaultFolder(olFolderSentMail)
    Set oSentItems = oSentFolder.Items


    intFolder = intTarget
    Select Case intFolder
        Case 1: strFolder = "1. Latest"
        Case 2: strFolder = "2. Received"
        Case 3: strFolder = "3. Sent"
    End Select

    On Error Resume Next
    Set tFolder = oNS.Session.GetDefaultFolder(olFolderInbox).Parent.Folders(strFolder)
    If Err <> 0 Then
        Err.Clear
        Set tFolder = oNS.Session.GetDefaultFolder(olFolderInbox).Parent.Folders.Add(strFolder)
    End If
    On Error GoTo 0

    intMode = intTarget
    Select Case intFolder
        Case 1: For i = LBound(varList) To UBound(varList)
                    strSentFilter = "@SQL=" & "urn:schemas:httpmail:displayto" & _
                                " Like '%" & CStr(varList(i)) & "%' Or " & _
                                "urn:schemas:httpmail:displaycc" & _
                                " Like '%" & CStr(varList(i)) & "%' Or " & _
                                "urn:schemas:httpmail:displaybcc" & _
                                " Like '%" & CStr(varList(i)) & "%'"

                    Set oFilteredInboxItems = oInboxItems.Restrict("[SenderEmailAddress] = '" & CStr(varList(i)) & "'")
                    With oFilteredInboxItems
                        If .Count > 0 Then
                            oFilteredInboxItems.Sort "[ReceivedTime]", True
                            theReceivedTime = oFilteredInboxItems(1).ReceivedTime
                        End If
                    End With

                    'Set oFilteredSentItems = oSentItems.Restrict("[To] = '" & CStr(varList(i)) & "'")
                    Set oFilteredSentItems = oSentItems.Restrict(strSentFilter)
                    With oFilteredSentItems
                        If .Count > 0 Then
                            oFilteredSentItems.Sort "[SentOn]", True
                            theSentTime = oFilteredSentItems(1).SentOn
                        End If
                    End With

                    If oFilteredInboxItems.Count > 0 And oFilteredSentItems.Count = 0 Then
                        Set oItem = oFilteredInboxItems(1)
                    End If

                    If oFilteredInboxItems.Count = 0 And oFilteredSentItems.Count > 0 Then
                        Set oItem = oFilteredSentItems(1)
                    End If

                    If oFilteredInboxItems.Count > 0 And oFilteredSentItems.Count > 0 Then
                        If theReceivedTime > theSentTime Then
                            Set oItem = oFilteredInboxItems(1)
                        Else
                            Set oItem = oFilteredSentItems(1)
                        End If
                    End If

                    oItem.Copy
                    oItem.Move tFolder
                    Debug.Print oFilteredInboxItems(1).Subject, theReceivedTime, oFilteredSentItems(1).Subject, theSentTime

                    Set oFilteredInboxItems = Nothing: Set oFilteredSentItems = Nothing: Set oFilteredItems = Nothing
                    Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
                Next

        Case 2: For i = LBound(varList) To UBound(varList)
                    Set oFilteredInboxItems = oInboxItems.Restrict("[SenderEmailAddress] = '" & CStr(varList(i)) & "'")
                    With oFilteredInboxItems
                        If .Count > 0 Then
                            oFilteredInboxItems.Sort "[ReceivedTime]", True
                            theReceivedTime = oFilteredInboxItems(1).ReceivedTime
                            Set oReceivedItem = oFilteredInboxItems(1).Copy
                            oReceivedItem.Move tFolder
                            Debug.Print CStr(varList(i)), oReceivedItem.Subject, theReceivedTime
                        End If
                    End With

                    Set oFilteredInboxItems = Nothing: Set oFilteredSentItems = Nothing: Set oFilteredItems = Nothing
                    Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
                Next

        Case 3: For i = LBound(varList) To UBound(varList)
                    strSentFilter = "@SQL=" & "urn:schemas:httpmail:displayto" & _
                                " Like '%" & CStr(varList(i)) & "%' Or " & _
                                "urn:schemas:httpmail:displaycc" & _
                                " Like '%" & CStr(varList(i)) & "%' Or " & _
                                "urn:schemas:httpmail:displaybcc" & _
                                " Like '%" & CStr(varList(i)) & "%'"

                    'Set oFilteredSentItems = oSentItems.Restrict("[To] = '" & CStr(varList(i)) & "'")
                    Set oFilteredSentItems = oSentItems.Restrict(strSentFilter)
                    With oFilteredSentItems
                        Debug.Print i, CStr(varList(i)), .Count
                        If .Count > 0 Then
                            oFilteredSentItems.Sort "[SentOn]", True
                            theSentTime = oFilteredSentItems(1).SentOn
                            Set oSentItem = oFilteredSentItems(1).Copy
                            oSentItem.Move tFolder
                            Debug.Print i, CStr(varList(i)), oSentItem.Subject, theSentTime
                        End If
                    End With

                    Set oFilteredInboxItems = Nothing: Set oFilteredSentItems = Nothing: Set oFilteredItems = Nothing
                    Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
                Next
    End Select
End Sub

2020 年 4 月 20 日编辑

根据 Dmitry 的建议，我将代码修改如下，但它似乎不适用于已发送的项目。我有2个问题，希望有人能帮忙。

1. 它不会捕获最新/最新的电子邮件。我怀疑这与用于查找收件人电子邮件地址的过滤器有关。有人可以帮助改进过滤器，以便它可以在所有收件人、抄送和密件抄送字段中查找收件人的电子邮件地址吗？
2. 如果我有一长串要找到的电子邮件地址，它会错过/跳过一些电子邮件地址（似乎查找功能不会为某些电子邮件地址返回任何结果）。目标电子邮件在那里，但代码无法提取相应的电子邮件。

下面是修改后的代码：

Sub Get_The_Emails(intTarget As Integer)
    Dim oInboxFolder As Outlook.folder, oSentFolder As Outlook.folder
    Dim tFolder As Outlook.folder, sFolder As Outlook.folder
    Dim oNS As Outlook.NameSpace
    Dim oInboxItems As Outlook.Items, oSentItems As Outlook.Items, colItems As Outlook.Items
    Dim oFilteredInboxItems As Outlook.Items, oFilteredSentItems As Outlook.Items, oFilteredItems As Outlook.Items
    Dim oReceivedItem As Outlook.MailItem, oSentItem As Outlook.MailItem, oItem As Outlook.MailItem
    Dim strFolder As String
    Dim strSentFilter As String, strReceivedFilter As String
    Dim intFolder As Integer, intMode As Integer, intSource As Integer
    Dim theReceivedTime As Date, theSentTime As Date
    Dim inputFile As String
    Dim inputNum As Integer, i As Integer
    Dim strEnviro As String, strContent As String
    Dim varList As Variant

    strEnviro = CStr(Environ("USERPROFILE"))
    inputFile = strEnviro & "\Desktop\Email-List.txt"

    If Dir(inputFile, vbDirectory) = "" Then
        MsgBox "File: " & inputFile & " could not be found", vbCritical, "Error"
        Exit Sub
    Else
        CleanList inputFile
        DoEvents
    End If

    inputNum = FreeFile
    Open inputFile For Input As inputNum
        strContent = Input(LOF(inputNum), inputNum)
    Close inputNum

    If Len(strContent) < 6 Then
        MsgBox "Invalid email address list", vbCritical, "Error"
        Exit Sub
    Else
        varList = Split(strContent, vbNewLine)
    End If

    Set oNS = Application.GetNamespace("MAPI")
    Set oInboxFolder = oNS.Session.GetDefaultFolder(olFolderInbox)
    Set oInboxItems = oInboxFolder.Items
    Set oSentFolder = oNS.Session.GetDefaultFolder(olFolderSentMail)
    Set oSentItems = oSentFolder.Items

    intFolder = intTarget
    Select Case intFolder
        Case 1: strFolder = "1. Latest"
        Case 2: strFolder = "2. Received"
        Case 3: strFolder = "3. Sent"
    End Select

    On Error Resume Next
    Set tFolder = oNS.Session.GetDefaultFolder(olFolderInbox).Parent.Folders(strFolder)
    If Err <> 0 Then
        Err.Clear
        Set tFolder = oNS.Session.GetDefaultFolder(olFolderInbox).Parent.Folders.Add(strFolder)
    End If
    On Error GoTo 0

    intMode = intTarget
    Select Case intFolder
        Case 1
                For i = LBound(varList) To UBound(varList)
                    strSentFilter = "@SQL=" & "urn:schemas:httpmail:displayto" & _
                                " Like '%" & CStr(varList(i)) & "%' Or " & _
                                "urn:schemas:httpmail:displaycc" & _
                                " Like '%" & CStr(varList(i)) & "%' Or " & _
                                "urn:schemas:httpmail:displaybcc" & _
                                " Like '%" & CStr(varList(i)) & "%'"

                    oInboxItems.Sort "[ReceivedTime]", True
                    Set oReceivedItem = oInboxItems.Find("[SenderEmailAddress] = '" & CStr(varList(i)) & "'")
                    If Not oReceivedItem Is Nothing Then
                        theReceivedTime = oReceivedItem.ReceivedTime
                    End If

                    oSentItems.Sort "[SentOn]", True
                    Set oSentItem = oSentItems.Find(strSentFilter)
                    If Not oSentItem Is Nothing Then
                        theSentTime = oSentItem.SentOn
                    End If

                    If Not oReceivedItem Is Nothing And oSentItem Is Nothing Then
                        Set oItem = oReceivedItem
                    End If

                    If oReceivedItem Is Nothing And Not oSentItem Is Nothing Then
                        Set oItem = oSentItem
                    End If

                    If Not oReceivedItem Is Nothing And Not oSentItem Is Nothing Then
                        If theReceivedTime > theSentTime Then
                            Set oItem = oReceivedItem
                        Else
                            Set oItem = oSentItem
                        End If
                    End If

                    oItem.Copy
                    oItem.Move tFolder
                    If Not oReceivedItem Is Nothing And Not oSentItem Is Nothing Then
                        Debug.Print "*** 1. Latest from/to: " & CStr(varList(i)) & " ***"
                        Debug.Print , "Received:" & vbTab, oReceivedItem.Subject, theReceivedTime
                        Debug.Print , "Sent:" & vbTab, oSentItem.Subject, theSentTime
                        Debug.Print "=================================================="
                    End If

                    Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
                Next

        Case 2
                For i = LBound(varList) To UBound(varList)
                    oInboxItems.Sort "[ReceivedTime]", True
                    Set oReceivedItem = oInboxItems.Find("[SenderEmailAddress] = '" & CStr(varList(i)) & "'")
                    If Not oReceivedItem Is Nothing Then
                        theReceivedTime = oReceivedItem.ReceivedTime
                        oReceivedItem.Copy
                        oReceivedItem.Move tFolder
                        Debug.Print "*** 2. Received from: " & CStr(varList(i)) & " ***"
                        Debug.Print , oReceivedItem.Subject, theReceivedTime
                        Debug.Print "================================================="
                    End If

                    Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
                Next

        Case 3
                For i = LBound(varList) To UBound(varList)
                    strSentFilter = "@SQL=" & "urn:schemas:httpmail:displayto" & _
                                " Like '%" & CStr(varList(i)) & "%' Or " & _
                                "urn:schemas:httpmail:displaycc" & _
                                " Like '%" & CStr(varList(i)) & "%' Or " & _
                                "urn:schemas:httpmail:displaybcc" & _
                                " Like '%" & CStr(varList(i)) & "%'"

                    oSentItems.Sort "[SentOn]", True
                    Set oSentItem = oSentItems.Find(strSentFilter)
                    If Not oSentItem Is Nothing Then
                        theSentTime = oSentItem.SentOn
                        oSentItem.Copy
                        oSentItem.Move tFolder
                        Debug.Print "*** 3. Sent to: " & CStr(varList(i)) & " ***"
                        Debug.Print , oSentItem.Subject, theSentTime
                        Debug.Print "==========================================="
                    End If

                    Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
                Next
    End Select
End Sub

标签： vbaoutlook

Answer 1

似乎对新过滤器“strSentFilter”的转换是不完整的。

替换旧过滤器后，这似乎是“查找发送到特定电子邮件地址或从特定电子邮件地址接收的最新电子邮件，并将其副本保存到特定文件夹。”

Option Explicit

Private Sub Get_The_Emails_TEST()

    ' 1. Latest
    ' 2. Received
    ' 3. Sent

    Get_The_Emails 1

End Sub


Sub Get_The_Emails(intTarget As Long)

    Dim oInboxFolder As Folder, oSentFolder As Folder
    Dim tFolder As Folder, sFolder As Folder

    Dim oInboxItems As items, oSentItems As items
    Dim oFilteredInboxItems As items, oFilteredSentItems As items

    Dim oReceivedItem As MailItem, oSentItem As MailItem, oItem As MailItem

    Dim strFolder As String
    Dim strSentFilter As String, strReceivedFilter As String

    Dim intFolder As Long, intMode As Long, intSource As Long
    Dim theReceivedTime As Date, theSentTime As Date

    Dim inputNum As Long, i As Long
    Dim strEnviro As String, strContent As String

    'Dim varList As Variant
    Dim varList() As Variant

    ' for testing without "Email-List.txt"
    varList() = Array("[e-mail]", "[e-mail]", "[e-mail]")

    'strEnviro = CStr(Environ("USERPROFILE"))
    'inputFile = strEnviro & "\Desktop\Email-List.txt"

    'If dir(inputFile, vbDirectory) = "" Then
    '    MsgBox "File: " & inputFile & " could not be found", vbCritical, "Error"
    '    Exit Sub
    'Else
    '    CleanList inputFile
    '    DoEvents
    'End If

    'inputNum = FreeFile
    'Open inputFile For Input As inputNum
    '    strContent = Input(LOF(inputNum), inputNum)
    'Close inputNum

    'If Len(strContent) < 6 Then
    '    MsgBox "Invalid email address list", vbCritical, "Error"
    '    Exit Sub
    'Else
    '    varList = Split(strContent, vbNewLine)
    'End If

    Set oInboxFolder = Session.GetDefaultFolder(olFolderInbox)
    Set oInboxItems = oInboxFolder.items

    Set oSentFolder = Session.GetDefaultFolder(olFolderSentMail)
    Set oSentItems = oSentFolder.items

    intFolder = intTarget
    Select Case intFolder
        Case 1: strFolder = "1. Latest"
        Case 2: strFolder = "2. Received"
        Case 3: strFolder = "3. Sent"
    End Select

    On Error Resume Next
    Set tFolder = Session.GetDefaultFolder(olFolderInbox).Parent.folders(strFolder)
    If Err <> 0 Then
        Err.Clear
        Set tFolder = Session.GetDefaultFolder(olFolderInbox).Parent.folders.Add(strFolder)
    End If
    On Error GoTo 0

    intMode = intTarget
    Select Case intFolder

        Case 1: For i = LBound(varList) To UBound(varList)

                    Debug.Print
                    Debug.Print i, CStr(varList(i))

                    strSentFilter = "@SQL=" & "urn:schemas:httpmail:displayto" & _
                                " Like '%" & CStr(varList(i)) & "%' Or " & _
                                "urn:schemas:httpmail:displaycc" & _
                                " Like '%" & CStr(varList(i)) & "%' Or " & _
                                "urn:schemas:httpmail:displaybcc" & _
                                " Like '%" & CStr(varList(i)) & "%'"

                    'Set oFilteredInboxItems = oInboxItems.Restrict("[SenderEmailAddress] = '" & CStr(varList(i)) & "'")
                    Set oFilteredInboxItems = oInboxItems.Restrict(strSentFilter)

                    With oFilteredInboxItems
                        If .count > 0 Then
                            oFilteredInboxItems.sort "[ReceivedTime]", True
                            theReceivedTime = oFilteredInboxItems(1).ReceivedTime

                            Debug.Print "Inbox:"
                            Debug.Print theReceivedTime & " " & oFilteredInboxItems(1).Subject
                        End If
                    End With

                    'Set oFilteredSentItems = oSentItems.Restrict("[To] = '" & CStr(varList(i)) & "'")
                    Set oFilteredSentItems = oSentItems.Restrict(strSentFilter)

                    With oFilteredSentItems
                        If .count > 0 Then
                            oFilteredSentItems.sort "[SentOn]", True
                            theSentTime = oFilteredSentItems(1).SentOn

                            Debug.Print "Sent folder:"
                            Debug.Print theSentTime & " " & oFilteredSentItems(1).Subject
                        End If
                    End With

                    If oFilteredInboxItems.count > 0 And oFilteredSentItems.count = 0 Then
                        Set oItem = oFilteredInboxItems(1)
                        Debug.Print "Inbox:"
                    End If

                    If oFilteredInboxItems.count = 0 And oFilteredSentItems.count > 0 Then
                        Set oItem = oFilteredSentItems(1)
                        Debug.Print "Sent folder:"
                    End If

                    If oFilteredInboxItems.count > 0 And oFilteredSentItems.count > 0 Then
                        If theReceivedTime > theSentTime Then
                            Set oItem = oFilteredInboxItems(1)
                            Debug.Print "Inbox item chosen:"
                        Else
                            Set oItem = oFilteredSentItems(1)
                            Debug.Print "Sent folder item chosen:"
                        End If
                    End If

                    If Not oItem Is Nothing Then
                        oItem.Copy
                        oItem.Move tFolder
                        Debug.Print oItem.Subject
                    Else
                        Debug.Print "No item found."
                    End If

                    Set oFilteredInboxItems = Nothing: Set oFilteredSentItems = Nothing
                    Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
                Next

        Case 2: For i = LBound(varList) To UBound(varList)

                    Debug.Print
                    Debug.Print i, CStr(varList(i))

                    strSentFilter = "@SQL=" & "urn:schemas:httpmail:displayto" & _
                                " Like '%" & CStr(varList(i)) & "%' Or " & _
                                "urn:schemas:httpmail:displaycc" & _
                                " Like '%" & CStr(varList(i)) & "%' Or " & _
                                "urn:schemas:httpmail:displaybcc" & _
                                " Like '%" & CStr(varList(i)) & "%'"

                    'Set oFilteredInboxItems = oInboxItems.Restrict("[SenderEmailAddress] = '" & CStr(varList(i)) & "'")
                    Set oFilteredInboxItems = oInboxItems.Restrict(strSentFilter)

                    With oFilteredInboxItems
                        If .count > 0 Then
                            oFilteredInboxItems.sort "[ReceivedTime]", True
                            theReceivedTime = oFilteredInboxItems(1).ReceivedTime
                            Set oReceivedItem = oFilteredInboxItems(1).Copy
                            oReceivedItem.Move tFolder

                            Debug.Print "Inbox:"
                            Debug.Print theReceivedTime & " " & oFilteredInboxItems(1).Subject
                        Else
                            Debug.Print "No item found."
                        End If
                    End With

                    Set oFilteredInboxItems = Nothing: Set oFilteredSentItems = Nothing
                    Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
                Next

        Case 3: For i = LBound(varList) To UBound(varList)

                    Debug.Print
                    Debug.Print i, CStr(varList(i))

                    strSentFilter = "@SQL=" & "urn:schemas:httpmail:displayto" & _
                                " Like '%" & CStr(varList(i)) & "%' Or " & _
                                "urn:schemas:httpmail:displaycc" & _
                                " Like '%" & CStr(varList(i)) & "%' Or " & _
                                "urn:schemas:httpmail:displaybcc" & _
                                " Like '%" & CStr(varList(i)) & "%'"

                    'Set oFilteredSentItems = oSentItems.Restrict("[To] = '" & CStr(varList(i)) & "'")
                    Set oFilteredSentItems = oSentItems.Restrict(strSentFilter)

                    With oFilteredSentItems

                        If .count > 0 Then
                            oFilteredSentItems.sort "[SentOn]", True
                            theSentTime = oFilteredSentItems(1).SentOn
                            Set oSentItem = oFilteredSentItems(1).Copy
                            oSentItem.Move tFolder

                            Debug.Print "Sent folder:"
                            Debug.Print theSentTime & " " & oFilteredSentItems(1).Subject
                        Else
                            Debug.Print "No item found."
                        End If
                    End With

                    Set oFilteredInboxItems = Nothing: Set oFilteredSentItems = Nothing
                    Set oReceivedItem = Nothing: Set oSentItem = Nothing: Set oItem = Nothing
                Next
    End Select
End Sub