按降序排列电子邮件

Question

我遍历所有电子邮件以查找具有特定主题行的电子邮件。

它总是从最旧的开始，并且要花很多时间，因为大多数邮件都是最新的。

Dim outMailItem As Outlook.MailItem
Dim inputDate As String, subjectFilter As String
Dim saveInFolder As   String
Dim filesys, newfolder, newfolderpath
OutlookOpened = False
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set outApp = New Outlook.Application
OutlookOpened = True
End If
On Error GoTo 0

If outApp Is Nothing Then
MsgBox "Cannot start Outlook.", vbExclamation
Exit Sub
End If

Set outNs = outApp.GetNamespace("MAPI")

Set outFolder = outNs.Folders("Personal Folders").Folders("Inbox")  
'Set outFolder = outNs.PickFolder                                   
Set outItems = outFolder.Items

If Not outFolder Is Nothing Then
    outItems.Sort "[ReceivedTime]", False
    For Each outItems In outFolder.Items
        If outItems.Class = Outlook.OlObjectClass.olMail Then

            Set outMailItem = outItems
            randomdate = Format(outMailItem.SentOn, "dd/mm/yy")
            If outMailItem.Subject = subjectFilter Then

                If randomdate = inputDate1 Then

                    Debug.Print outMailItem.Subject
                    For Each outAttachment In outMailItem.Attachments
                        outAttachment.SaveAsFile saveInFolder & outAttachment.Filename
                    Next
                End If
            End If
        End If
    Next

我已经按照排序顺序尝试了True和False。

Answer 1

您为什么需要遍历all个项目？使用Items.Find / FindNext查找Subject属性值的匹配项。

set outMailItem = outItems.Find("[Subject] = '" & subjectFilter & "'")

如果有多个匹配项，则可以使用Findf / FindNext遍历所有匹配项

set outMailItem = outItems.Find("[Subject] = '" & subjectFilter & "'")
while Not (outMailItem  Is Nothing)
  'do something with outMailItem 
  set outMailItem  = outItems.FindNext
wend