从收到日期提取电子邮件附件-VBA

提前感谢您的帮助

我有一个代码，可以帮助我从特定的电子邮件文件夹中提取所有电子邮件附件。它工作得很好。但现在我想更改为从我在对话框中输入的日期开始提取电子邮件附件（我只想提取我在过去七天收到的电子邮件的电子邮件附件，而不是整个文件夹）。请查找以下代码以供参考：

Sub Extract_emails()
    Dim OlApp As Object
    Dim OlMail As Object
    Dim OlItems As Object
    Dim Olfolder As Object
    Dim J As Integer
    Dim strFolder As String

    Set OlApp = GetObject(, "Outlook.Application")        
    If Err.Number = 429 Then
    Set OlApp = CreateObject("Outlook.Application")   
    End If

    strFolder = ThisWorkbook.Path & "\Extract"            
    Set Olfolder = OlApp.getnamespace("MAPI").Folders("MyEmailAddress").Folders("Inbox")
    Set OlItems = Olfolder.Items

    For Each OlMail In OlItems
    If OlMail.Attachments.Count > 0 Then
        For J = 1 To OlMail.Attachments.Count
        OlMail.Attachments.Item(J).SaveAsFile strFolder & "\" & OlMail.Attachments.Item(J).Filename
        Next J

    End If

    Set OlApp = Nothing
    Set OlMail = Nothing
    Set OlItems = Nothing
    Set Olfolder = Nothing

    Next

    MsgBox ("Done")
End Sub

其他信息

谢谢你的帮助，托尼，我正在添加更多信息

你猜对了。我只需要提取xlsx电子邮件附件（供应商在邮件中发送excel和pdf文档）并将其保存在文件夹中。之后，我需要代码打开保存的excel，复制数据库中的数据，并关闭保存的xlsx。我不知道xlsx文件的名称（通常是我们公司的名称和一些数字），但每个报告都有“发货”表，我从中复制数据库中的数据。没有人读这封邮件，这就是为什么我尝试使用未读邮件。请看下面的代码，当我使用F8时，它对我有效，但不适用于F5

 Set OlApp = GetObject(, "Outlook.Application")

 If Err.Number = 429 Then
 Set OlApp = CreateObject("Outlook.Application")
 End If

 strFolder = ThisWorkbook.Path & "\Extract"
 Set Olfolder = OlApp.getnamespace("MAPI").Folders("Freight.Invoice@omega.com").Folders("Inbox")
Set OlItems = Olfolder.Items


For Each OlMail In OlItems

If OlMail.UnRead = True Then

    If OlMail.Attachments.Count > 0 Then

        For J = 1 To OlMail.Attachments.Count
        FilePath = strFolder & "\" & OlMail.Attachments.Item(J).FileName
        OlMail.Attachments.Item(J).SaveAsFile FilePath
            If Right(FilePath, 4) = "xlsx" Then

                runit FilePath
                    For I = 1 To Worksheets.Count
                        If Worksheets(I).Name = "Shipped" Then
                            Worksheets("Shipped").Activate
                            Set wsCopy = Worksheets("Shipped")
                            Set wsDest = Workbooks("Extract 
 emails.xlsm").Worksheets("DATA")
                            lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, 
 "B").End(xlUp).Row
                            lDestLastRow = wsDest.Cells(wsDest.Rows.Count, 
"B").End(xlUp).Offset(1).Row
                            wsCopy.Range("B4:K" & lCopyLastRow).Copy _
                            wsDest.Range("B" & lDestLastRow)

                            Worksheets("Shipped").Activate
                            ActiveWorkbook.Close savechanges:=False


                        End If
                    Next

            End If

        Next J

     End If

End If


Next

For Each OlMail In OlItems

If OlMail.UnRead = True Then
OlMail.UnRead = False
DoEvents
OlMail.Save

End If

Set OlApp = Nothing
Set OlMail = Nothing
Set OlItems = Nothing
Set Olfolder = Nothing

Next


MsgBox ("Done")


End Sub 


Sub runit(FilePath As String)

Dim Shex As Object
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long


Set Shex = CreateObject("Shell.Application")
Shex.Open (FilePath)

End Sub

---

这是一个教程，而不是对你的问题的直接回答。我涵盖了你需要知道的一切。我相信您会发现这种方法比“运行此代码，它就会工作”的答案更有用。我希望我已经充分解释了一切。如果有必要，带着问题回来

您需要将电子邮件的接收时间与要求的最早日期进行比较。你说你打算输入最早的规定日期，你还说你想要最后七天。也许还有其他选择。在即时窗口中键入以下命令（注释除外）

? now()                                The current date and time
? datevalue(now())                     The current date      
? dateadd("d",-7,now())                Seven days before now
? dateadd("d",-7,datevalue(now()))     Seven days ago
? dateadd("ww",-1,datevalue(now()))    One week ago

这些表达方式中有哪一个能告诉你你想要的日期吗？在

DateAdd

中，“d”和“ww”是间隔，其中“d”表示天，“ww”表示周。还有其他值，如“w”表示工作日。如果这些表达式中的一个几乎满足了您的需求，请进行实验

其他可能性包括在保存附件时设置类别或自定义特性

如果尚未这样做，请打开工作簿和VBA编辑器。单击[工具]，然后单击[参考…]。“Microsoft Outlook nn.n对象库”是否在列表顶部附近并勾选？注意：“nn.n”取决于您使用的Office版本。如果未列出并勾选此库，请向下滚动直到找到它，然后单击小框以勾选它。这使您的工作簿可以访问Outlook数据项，因此您不必指定太多的对象

现在创建一个新模块，并将下面的代码复制到其中。如果运行宏

Demo（）

，将得到如下输出：

Oldest additions to Inbox
  [14/12/2019 18:21:21]  [28/12/2019 05:05:00]  [08/01/2020 18:37:09]  [28/03/2019 16:16:12]  [21/03/2019 14:00:08]
  [14/06/2018 21:02:34]  [03/02/2020 09:29:38]  [06/03/2020 17:03:50]  [11/03/2020 13:43:33]  [12/03/2020 00:07:53]
  [13/03/2020 08:46:58]  [13/03/2020 17:31:23]  [14/03/2020 03:42:53]  [14/03/2020 08:07:35]  [14/03/2020 08:58:11]
  [15/03/2020 19:43:16]  [16/03/2020 16:48:40]  [16/03/2020 20:39:58]  [17/03/2020 11:14:29]  [18/03/2020 01:43:37]

Newest additions to Inbox
  [18/03/2020 01:43:37]  [17/03/2020 11:14:29]  [16/03/2020 20:39:58]  [16/03/2020 16:48:40]  [15/03/2020 19:43:16]
  [14/03/2020 08:58:11]  [14/03/2020 08:07:35]  [14/03/2020 03:42:53]  [13/03/2020 17:31:23]  [13/03/2020 08:46:58]
  [12/03/2020 00:07:53]  [11/03/2020 13:43:33]  [06/03/2020 17:03:50]  [03/02/2020 09:29:38]  [14/06/2018 21:02:34]
  [21/03/2019 14:00:08]  [28/03/2019 16:16:12]  [08/01/2020 18:37:09]  [28/12/2019 05:05:00]  [14/12/2019 18:21:21]

Newest emails in Inbox
  [20/03/2020 12:16:47]  [20/03/2020 00:00:14]  [19/03/2020 17:51:21]  [19/03/2020 17:06:38]  [19/03/2020 10:19:36]
  [18/03/2020 16:21:25]  [18/03/2020 01:43:37]  [17/03/2020 11:14:29]  [16/03/2020 20:39:58]  [16/03/2020 16:48:40]
  [15/03/2020 19:43:16]  [14/03/2020 08:58:11]  [14/03/2020 08:07:35]  [14/03/2020 03:42:53]  [13/03/2020 17:31:23]
  [13/03/2020 08:46:58]  [12/03/2020 00:07:53]  [11/03/2020 13:43:33]  [06/03/2020 17:03:50]  [03/02/2020 09:29:38]

Oldest emails in Inbox
  [14/06/2018 21:02:34]  [21/03/2019 14:00:08]  [28/03/2019 16:16:12]  [14/12/2019 18:21:21]  [28/12/2019 05:05:00]
  [08/01/2020 18:37:09]  [03/02/2020 09:29:38]  [06/03/2020 17:03:50]  [11/03/2020 13:43:33]  [12/03/2020 00:07:53]
  [13/03/2020 08:46:58]  [13/03/2020 17:31:23]  [14/03/2020 03:42:53]  [14/03/2020 08:07:35]  [14/03/2020 08:58:11]
  [15/03/2020 19:43:16]  [16/03/2020 16:48:40]  [16/03/2020 20:39:58]  [17/03/2020 11:14:29]  [18/03/2020 01:43:37]

注意事项：

我有

Dim OutApp作为新Outlook.Application

。“New”表示创建引用，而不仅仅是为引用创建数据项。这意味着我不需要

GetObject

或

CreateObject

。Outlook一次只允许自己出现一次，因此我的“新建”或您的

CreateObject

将引用现有的事件或根据需要创建一个新的事件。我还有

OutApp.Quit

。这将关闭Outlook，无论它是否已打开。在使用Excel工作簿访问Outlook时，我不使用Outlook，因此我希望关闭Outlook。如果您在意，请使用Get或Create代码记录成功的代码，以便知道是否需要退出

我将数据项命名为

OutApp

，而不是

olApp

。Outlook使用前缀“ol”作为其常量，因此我避免使用此前缀，以防我的名字与Outlook的名字匹配

我使用了

Session

而不是

GetNamespace（“MAPI”）

。它们只是实现相同效果的不同方式

ItemsInbox

是一个“集合”；其他语言称之为“列表”。集合就像一个数组，除了可以在任何现有条目之前、在任何现有条目中或在任何条目之后添加新条目。可以删除任何现有条目

Outlook在收集的末尾添加新电子邮件。所以，如果你从头到尾阅读，第一封电子邮件就是收件箱中最长的一封。如果你从头到尾阅读，第一封电子邮件就是最近添加到收件箱的电子邮件。这表明你可以从头到尾阅读，先看最近的电子邮件，当你收到超出范围的电子邮件时可以停止阅读。但是，如果您将旧电子邮件从收件箱移动到另一个文件夹，然后将其移回，则不会将其返回到旧位置；相反，它将被添加到末尾

在下面的宏中，我首先列出了20封电子邮件的接收时间，从第一封到最后一封，然后从最后一封到第一封。你可能会发现有些是顺序错误的

然后，我按ReceivedTime的降序和升序排序后，列出了20封电子邮件的ReceivedTime

研究四组日期。特别要注意不同的顺序。我相信第三组日期后面的代码最适合您

我想我已经涵盖了所有内容，但正如我所说的，如果有必要，我会回来提问，我会修复任何缺陷

Option Explicit

  ' Needs reference to "Microsoft Outlook n.nn Object Library"
  ' where n.nn depends on the version of Outlook you are using.

Sub Demo()

  Dim FldrInbox As Outlook.Folder
  Dim InxICrnt As Long
  Dim InxIMax As Long
  Dim ItemsInbox As Outlook.Items
  Dim NumOnLine As Long
  Dim OutApp As New Outlook.Application

  Set FldrInbox = OutApp.Session.Folders("a.j.dallimore@xxxxxxx.com").Folders("Inbox")

  Set ItemsInbox = FldrInbox.Items

  If ItemsInbox.Count > 20 Then
    InxIMax = 20
  Else
    InxIMax = ItemsInbox.Count
  End If

  Debug.Print "Oldest additions to Inbox"
  NumOnLine = 0
  For InxICrnt = 1 To InxIMax
    Debug.Print "  [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
    NumOnLine = NumOnLine + 1
    If NumOnLine = 5 Then
      Debug.Print
      NumOnLine = 0
    End If
  Next
  Debug.Print

  Debug.Print "Newest additions to Inbox"
  NumOnLine = 0
  For InxICrnt = InxIMax To 1 Step -1
    Debug.Print "  [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
    NumOnLine = NumOnLine + 1
    If NumOnLine = 5 Then
      Debug.Print
      NumOnLine = 0
    End If
  Next
  Debug.Print

  ItemsInbox.Sort "ReceivedTime", True
  Debug.Print "Newest emails in Inbox"
  NumOnLine = 0
  For InxICrnt = 1 To InxIMax
    Debug.Print "  [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
    NumOnLine = NumOnLine + 1
    If NumOnLine = 5 Then
      Debug.Print
      NumOnLine = 0
    End If
  Next
  Debug.Print

  ItemsInbox.Sort "ReceivedTime", False
  Debug.Print "Oldest emails in Inbox"
  NumOnLine = 0
  For InxICrnt = 1 To InxIMax
    Debug.Print "  [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
    NumOnLine = NumOnLine + 1
    If NumOnLine = 5 Then
      Debug.Print
      NumOnLine = 0
    End If
  Next
  Debug.Print

  Set ItemsInbox = Nothing
  OutApp.Quit
  Set OutApp = Nothing

End Sub

修订后的要求

大约每周，您都会收到一封来自供应商的电子邮件，其中包含PDF和XLSX格式的发票。Outlook规则识别该电子邮件并将其移动到专用文件夹。您的团队对PDF版本不感兴趣。XLSX工作簿的名称不一致。但是，它始终包含一个工作表“Shipped”，其中包含对您的团队有用的数据。目前，您不会尝试按宏处理该数据，但希望将其合并到您自己的工作簿中，以便团队方便地查看。目前，所需的格式为：

Columns B to K of row 4+ of worksheet “Shipped” for week starting 1Mar20
    :    :    :    :    :
Columns B to K of row 4+ of worksheet “Shipped” for week starting 8Mar20
    :    :    :    :    :
Columns B to K of row 4+ of worksheet “Shipped” for week starting 15Mar20
    :    :    :    :    :

审查了实现要求的想法

如果你

Data from email received 2Mar20 9:10
   Entire contents of worksheet “Shipped”
Data from email received 9Mar20 9:30
   Entire contents of worksheet “Shipped”
Data from email received 16Mar20 9:20
   Entire contents of worksheet “Shipped”

' Routines useful with Excel

Option Explicit
Public Sub FindLastRowCol(ByRef Wsht As Worksheet, ByRef RowLast As Long, _
                          ByRef ColLast As Long)

  ' Sets RowLast and ColLast to the last row and column with a value
  ' in worksheet Wsht

  ' The motivation for coding this routine was the discovery that Find by
  ' previous row found a cell formatted as Merge and Center but Find by
  ' previous column did not.
  ' I had known the Find would miss merged cells but this was new to me.

  '   Dec16  Coded
  ' 31Dec16  Corrected handling of UserRange
  ' 15Feb17  SpecialCells was giving a higher row number than Find for
  '          no reason I could determine.  Added code to check for a
  '          value on rows and columns above those returned by Find
  ' 25Jun17  Found column with value about that found by Find

  Dim ColCrnt As Long
  Dim ColLastFind As Long
  Dim ColLastOther As Long
  Dim ColLastTemp As Long
  Dim ColLeft As Long
  Dim ColRight As Long
  Dim Rng As Range
  Dim RowIncludesMerged As Boolean
  Dim RowBot As Long
  Dim RowCrnt As Long
  Dim RowLastFind As Long
  Dim RowLastOther As Long
  Dim RowLastTemp As Long
  Dim RowTop As Long

  With Wsht

    Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
    If Rng Is Nothing Then
      RowLastFind = 0
      ColLastFind = 0
    Else
      RowLastFind = Rng.Row
      ColLastFind = Rng.Column
    End If

    Set Rng = .Cells.Find("*", .Range("A1"), xlValues, , xlByColumns, xlPrevious)
    If Rng Is Nothing Then
    Else
      If RowLastFind < Rng.Row Then
        RowLastFind = Rng.Row
      End If
      If ColLastFind < Rng.Column Then
        ColLastFind = Rng.Column
      End If
    End If

    Set Rng = .Range("A1").SpecialCells(xlCellTypeLastCell)
    If Rng Is Nothing Then
      RowLastOther = 0
      ColLastOther = 0
    Else
      RowLastOther = Rng.Row
      ColLastOther = Rng.Column
    End If

    Set Rng = .UsedRange
    If Rng Is Nothing Then
    Else
      If RowLastOther < Rng.Row + Rng.Rows.Count - 1 Then
        RowLastOther = Rng.Row + Rng.Rows.Count - 1
      End If
      If ColLastOther < Rng.Column + Rng.Columns.Count - 1 Then
        ColLastOther = Rng.Column + Rng.Columns.Count - 1
      End If
    End If

    If RowLastFind < RowLastOther Then
      ' Higher row found by SpecialCells or UserRange
      Do While RowLastOther > RowLastFind
        ColLastTemp = .Cells(RowLastOther, .Columns.Count).End(xlToLeft).Column
        If ColLastTemp > 1 Or .Cells(RowLastOther, 1).Value <> "" Then
          Debug.Assert False
          ' Is this possible
          ' Row after RowLastFind has value
          RowLastFind = RowLastOther
          Exit Do
        End If
        RowLastOther = RowLastOther - 1
      Loop
    ElseIf RowLastFind > RowLastOther Then
      Debug.Assert False
      ' Is this possible
    End If
    RowLast = RowLastFind

    If ColLastFind < ColLastOther Then
      ' Higher column found by SpecialCells or UserRange
      Do While ColLastOther > ColLastFind
        RowLastTemp = .Cells(.Rows.Count, ColLastOther).End(xlUp).Row
        If RowLastTemp > 1 Or .Cells(1, ColLastOther).Value <> "" Then
          'Debug.Assert False
          ' Column after ColLastFind has value
          ' Possible causes:
          '   * Find does not recognise merged cells
          '   ' Find does not examine hidden cells
          ColLastFind = ColLastOther
          Exit Do
        End If
        ColLastOther = ColLastOther - 1
      Loop
    ElseIf ColLastFind > ColLastOther Then
      Debug.Assert False
      ' Is this possible
    End If
    ColLast = ColLastFind

  End With

End Sub
Public Function WshtExists(ByRef Wbk As Workbook, ByVal WshtName As String) As Boolean

  ' Returns True if Worksheet WshtName exists within
  '  * if Wbk Is Nothing the workbook containing the macros
  '  * else workbook Wbk

  ' 21Aug16  Coded by Tony Dallimore
  ' 14Feb17  Coded alternative routine that cycled through the existing worksheets
  '          matching their names against WshtName to check if use of "On Error Resume Next"
  '          was the faster option. I needed to call the routines 6,000,000 times each to
  '          get an adequate duration for comparison. This version took 33 seconds while
  '          the alternative took 75 seconds.
  ' 21Feb20  Added "As Boolean" to declaration. Do not understand how routine worked
  '          without it.

  Dim WbkLocal As Workbook
  Dim Wsht As Worksheet

  If Wbk Is Nothing Then
    Set WbkLocal = ThisWorkbook
  Else
    Set WbkLocal = Wbk
  End If

  Err.Clear
  On Error Resume Next
  Set Wsht = WbkLocal.Worksheets(WshtName)
  On Error GoTo 0
  If Wsht Is Nothing Then
    WshtExists = False
  Else
    WshtExists = True
  End If

End Function

' Routines useful with Outlook.

Option Explicit
Public Sub OutAppClose(ByRef OutApp As Outlook.Application, ByVal Created As Boolean)

  ' If Created is True, quit the current instance if Outlook.

  If Created Then
    OutApp.Quit
  End If

  Set OutApp = Nothing

End Sub
Public Function OutAppGetCreate(ByRef Created As Boolean) As Outlook.Application

  ' Return a reference to the Outlook Application.
  ' Set Created to True if the reference is to a new application and to
  ' False if the reference is to an existing application.

  ' If Nothing is returned, the routine has been unable to get or create a reference.

  ' Only one instance of Outlook can be running.  CreateObject("Outlook.Application")
  ' will return a reference to the existing instance if one is already running or
  ' will start a new instance if one is not running.  The disadvantage of using
  ' CreateObject, is the caller does not know if Outlook was running so does not know
  ' whether or not to quit Outlook when it has finished using Outlook.  By setting
  ' Created, this routine allows the caller to only quit if this is appropriate.

  Set OutAppGetCreate = Nothing
  On Error Resume Next
  Set OutAppGetCreate = GetObject(, "Outlook.Application")
  On Error GoTo 0
  If OutAppGetCreate Is Nothing Then
    On Error Resume Next
    Set OutAppGetCreate = CreateObject("Outlook.Application")
    On Error GoTo 0
    If OutAppGetCreate Is Nothing Then
      Call MsgBox("I am unable to access Outlook", vbOKOnly)
      Exit Function
    End If
    Created = True
  Else
    Created = False
  End If

End Function

Option Explicit

  ' * Need reference to "Microsoft Outlook nn.n Object Library"
  '   where nn.n depends on the version of Office being used.
  ' * Needs reference to "Microsoft Scripting Runtime"

  Const HeaderForData As String = "Data from email received"
  Const WbkConName As String = "Consolidated Data.xlsx"
  Const WshtName As String = "Shipped"  ' Also used for name of workbooks
Sub ConsolidateDataFromShippedWshts() ()

  ' Outlook used "ol" as a prefix for its constants. I do not use the same
  ' prefix to avoid a clash.
  Dim OutApp As Outlook.Application
  Dim OutAppCreated As Boolean

  Dim ColConLast As Long             ' Last column of worksheet "Shipped" in consolidated workbook
  Dim ColSrcLast As Long             ' Last column of worksheet "Shipped" in source workbook
  Dim DateLatestExisting As Date     ' Date of last block of data in consolidated workbook
  Dim DateStr As String              ' Date extracted from header row
  Dim FldrShipped As Outlook.Folder  ' Outlook Folder containing source emails
  Dim InxA As Long                   ' Index into attachments
  Dim InxI As Long                   ' Index into mail items
  Dim InxW As Long                   ' Into into WbkSrcNames
  Dim ItemsShipped As Items          ' Items in source folder
  Dim Path As String                 ' Disc folder containing workbooks
  Dim Rng As Range                   ' Various uses
  Dim RowConCrnt As Long             ' Current row of worksheet "Shipped" in consolidated workbook
  Dim RowConLast As Long             ' Last row of worksheet "Shipped" in consolidated workbook
  Dim RowSrcLast As Long             ' Last row of worksheet "Shipped" in source workbook
  Dim WbkCon As Workbook             ' Consolidated workbook
  Dim WbkMacros As Workbook          ' This workbook
  Dim WbkSrc As Workbook             ' Workbook extracted from email
  Dim WbkSrcName As String           ' Name of workbook extracted from email
  Dim WbkSrcNameDates As Collection  ' Collection of the names and dates of workbooks extracted from emails
  Dim WshtCon As Worksheet           ' Worksheet "Shipped" in consolidated workbook
  Dim WshtSrc As Worksheet           ' Worksheet "Shipped" in source workbook

  Application.ScreenUpdating = False

  Set WbkMacros = ThisWorkbook

  Path = WbkMacros.Path

  ' ### Change if you want a different name for consolidated workbook
  Set WbkCon = Workbooks.Open(Path & "\" & WbkConName)
  Set WshtCon = WbkCon.Worksheets(WshtName)

  ' Find last used row of consolidated worksheet
  Call FindLastRowCol(WshtCon, RowConLast, ColConLast)

  If RowConLast = 0 Then
    ' No data added yet
    DateLatestExisting = 0
  Else
    ' Search up for header for last block of data added
    With WshtCon
      Set Rng = .Columns(1).Find( _
                      What:=HeaderForData, After:=.Cells(RowConLast + 1, 1), _
                      LookIn:=xlValues, LookAt:=xlPart, _
                      SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
                      MatchCase:=False, SearchFormat:=False)
      If Rng Is Nothing Then
        Debug.Assert False
        ' It should not be possible to be here.  Either the worksheet is empty
        ' and RowColLast = 0 or one or more blocks of data, each with a header,
        ' have been added.  It appears the worksheet is not as it should be.
        DateLatestExisting = 0
      Else
        DateStr = Mid$(.Cells(Rng.Row, 1).Value, Len(HeaderForData) + 2)
        If IsDate(DateStr) Then
          DateLatestExisting = DateValue(DateStr) + TimeValue(DateStr)
        Else
          Debug.Assert False
          ' It should not be possible to be here.  The text after HeaderForData
          ' should be a valid date. It appears the worksheet is not as it should be.
          DateLatestExisting = 0
        End If
      End If

    End With
  End If

  Set OutApp = OutAppGetCreate(OutAppCreated)

  If OutApp Is Nothing Then
    ' OutAppGetCreated() failed.  The user has already been told.
    Exit Sub
  End If

  ' ### Change to access folder where you store these emails
  Set FldrShipped = OutApp.Session.Folders("MyName@MyIsp").Folders("Test")

  ' Create list of items in folder sorted by ReceivedTime
  Set ItemsShipped = FldrShipped.Items
  ItemsShipped.Sort "ReceivedTime", True

  Set WbkSrcNameDates = New Collection

  ' Read items, newest first, until reach an item at or before DateLatestExisting
  ' Save xlsx attachment, if any, and record names in WbkSrcNames
  For InxI = 1 To ItemsShipped.Count
    If TypeName(ItemsShipped(InxI)) = "MailItem" Then
      If ItemsShipped(InxI).ReceivedTime <= DateLatestExisting Then
        ' No more unprocessed emails
        Exit For
      End If
      ' Save Xlsx attachment, if any
      For InxA = 1 To ItemsShipped(InxI).Attachments.Count
        If LCase(Right$(ItemsShipped(InxI).Attachments(InxA).FileName, 5)) = ".xlsx" Then
          ' Have found required attachment. Save with name based on date received
          WbkSrcName = WshtName & " " & Format(ItemsShipped(InxI).ReceivedTime, "yymmdd hhmmss") & ".xlsx"
          ItemsShipped(InxI).Attachments(InxA).SaveAsFile Path & "\" & WbkSrcName
          WbkSrcNameDates.Add VBA.Array(WbkSrcName, ItemsShipped(InxI).ReceivedTime)
          Exit For
        End If
      Next
    End If
  Next

  Call OutAppClose(OutApp, OutAppCreated)

  If WbkSrcNameDates.Count = 0 Then
    ' No new emails with xlsx attachments
    WbkCon.Close SaveChanges:=False
    Call MsgBox("No new emails containing an xlsx attachment", vbOKOnly)
    Set WshtCon = Nothing
    Set WbkCon = Nothing
    Set WbkMacros = Nothing
    Exit Sub
  End If

  ' WbkSrcNameDates contains the names and received dates of the new workbooks
  ' with the newest first.
  ' Extract names in reverse order (oldest first) and add contents of worksheet
  ' "Shipped" to bottom of worksheet "Shipped" of consolidated workbook

  For InxW = WbkSrcNameDates.Count To 1 Step -1
    Set WbkSrc = Workbooks.Open(Path & "\" & WbkSrcNameDates(InxW)(0))
    If WshtExists(WbkSrc, WshtName) Then
      ' Worksheet "Shipped" exists
      Set WshtSrc = WbkSrc.Worksheets(WshtName)
      Call FindLastRowCol(WshtSrc, RowSrcLast, ColSrcLast)
      RowConCrnt = RowConLast + 1   ' Advance to first free row
      With WshtCon.Cells(RowConCrnt, 1)
        .Value = HeaderForData & " " & Format(WbkSrcNameDates(InxW)(1), "d-mmm-yy h:mm:ss")
        .Font.Bold = True
      End With
      RowConCrnt = RowConCrnt + 1
      With WshtSrc
        .Range(.Cells(1, 1), .Cells(RowSrcLast, ColSrcLast)).Copy _
                      Destination:=WshtCon.Cells(RowConCrnt, 1)
      End With
      RowConLast = RowConCrnt + RowSrcLast - 1
    End If

    WbkSrc.Close SaveChanges:=False
  Next

  ' Position cursor to header for latest data
  Application.ScreenUpdating = True
  WshtCon.Activate
  WshtCon.Cells(RowConLast - RowSrcLast, 1).Select
  Application.Goto ActiveCell, True
  WbkCon.Close SaveChanges:=True

  Set WshtCon = Nothing
  Set WbkCon = Nothing
  Set WbkMacros = Nothing

End Sub