将所有收件箱电子邮件（包括子文件夹）从Outlook导入到Excel

Question

我只是一个初学者，使用下面的宏代码借助Pickfolder和Date Range选项提取所有邮件项，它的工作原理非常出色-VBA无法限制MarkedAsCompleate电子邮件的导入，并且不包括非邮件项目-如交货失败，等：

    Option Explicit

     Sub ExportOutlookEmailsToExcel()
     Dim xlApp As Object
     Dim xlWb As Object
     Dim xlSheet As Object
     Dim rCount As Long
     Dim bXStarted As Boolean
     Dim strPath As String
     Dim mailItems As Outlook.Items
     Dim olItem As Outlook.MailItem
     Dim i As Long
     Dim cFolders As Collection
     Dim olFolder As Outlook.Folder
     Dim subFolder As Folder
     Dim iDays As Long: iDays = 7
     Dim strStartDate As String
     Dim strEndDate As String
     Dim MyRestrictions As Outlook.Items
     Dim MyItems As Outlook.MailItem

         strPath = "Y:\Documents\OutlookEmails.xlsx"

         strStartDate = InputBox("Enter the latest date", "Start Date", Format(Date, "Short Date"))
         If Not IsDate(strStartDate) Then
             If strStartDate = "" Then
                 MsgBox "No date selected, or user cancelled"
             Else
                 MsgBox strStartDate & " is invalid"
             End If
             GoTo lbl_Exit
         End If

         strEndDate = InputBox("Enter the earliest date", "End Date", Format(Date - iDays, "Short Date"))
         If Not IsDate(strEndDate) Then
             If strEndDate = "" Then
                 MsgBox "No date selected, or user cancelled"
             Else
                 MsgBox strEndDate & " is invalid"
             End If
             GoTo lbl_Exit
         End If

         On Error Resume Next
         Set xlApp = GetObject(, "Excel.Application")
         If Err <> 0 Then
             Set xlApp = CreateObject("Excel.Application")
             bXStarted = True
         End If
         On Error GoTo 0

         Set xlWb = xlApp.Workbooks.Add
         xlApp.Visible = True
         Set xlSheet = xlWb.Sheets("Sheet1")
         xlSheet.Name = "All Emails"

         xlSheet.Range("A" & 1) = "Sender Name"
         xlSheet.Range("B" & 1) = "Sent To"
         xlSheet.Range("C" & 1) = "Sent On"
         xlSheet.Range("D" & 1) = "subject"
         xlSheet.Range("E" & 1) = "Flag Status"
         xlSheet.Range("F" & 1) = "Categories"
         xlSheet.Range("G" & 1) = "Received Time"
         xlSheet.Range("H" & 1) = "Folder"
         xlSheet.Range("I" & 1) = "Flag Request"




         On Error Resume Next
         rCount = 2

         Set cFolders = New Collection
         cFolders.Add Session.PickFolder
         Do While cFolders.Count > 0
             Set olFolder = cFolders(1)
             Set mailItems = olFolder.Items
             mailItems.Sort "[SentOn]", True
             cFolders.Remove 1

Set MyRestrictions =  MyItems.Restrict("[FlagRequest] = 'Follow Up'")
             For i = MyRestrictions.Count To 1 Step -1
             For i = 1 To mailItems.Count
                 Set olItem = mailItems(i)
                 If Not olItem Is Nothing Then
                     If Format(olItem.ReceivedTime, "yyyymmdd") <= _
                        Format(CDate(strStartDate), "yyyymmdd") And _
                        Format(olItem.ReceivedTime, "yyyymmdd") >= _
                        Format(CDate(strEndDate), "yyyymmdd") Then

                         With olItem
                             xlSheet.Range("A" & rCount) = .SenderName
                             xlSheet.Range("B" & rCount) = .To
                             xlSheet.Range("C" & rCount) = .SentOn
                             xlSheet.Range("D" & rCount) = .Subject
                             xlSheet.Range("E" & rCount) = .FlagStatus
                             xlSheet.Range("F" & rCount) = .Categories
                             xlSheet.Range("G" & rCount) = .ReceivedTime
                             xlSheet.Range("H" & rCount) = olFolder.FolderPath
                             xlSheet.Range("I" & rCount) = .FlagRequest


                         End With
                         rCount = rCount + 1
                    ElseIf Format(olItem.ReceivedTime, "yyyymmdd") <= _
                           Format(CDate(strEndDate), "yyyymmdd") Then
          Exit For
                     End If
                 End If
                 DoEvents
             Next i
             For Each subFolder In olFolder.Folders
                 cFolders.Add subFolder
             Next subFolder
         Loop

         xlWb.SaveAs strPath

         xlWb.Close 1
         If bXStarted Then
             xlApp.Quit
         End If
         MsgBox ("All Emails Were Successfully imported except Delivery Failure Notifications")
    lbl_Exit:
         Set olItem = Nothing
         Set xlApp = Nothing
         Set xlWb = Nothing
         Set xlSheet = Nothing
         Set mailItems = Nothing
         Set olFolder = Nothing
         Exit Sub
     End Sub

即使在限制后续项目的导入之后-此代码也将全部导入，然后我必须手动将其删除-我在做什么错了？请帮忙！