excel - 对指定日期内的电子邮件使用限制方法

Question

我正在创建一个宏，以便在我们的团队共享框中按主题和接收日期获取电子邮件。我的问题是，一旦我选择了日期(例如 2018 年 1 月 16 日到 2018 年 1 月 17 日)，只有很少的电子邮件存储在对象中。
在下面的屏幕截图中，我有 9 项应用了限制方法。应该是从 2018 年 1 月 16 日到现在收到的 14 封邮件(屏幕截图中的右侧 Outlook 邮件)，但有 5 封邮件未存储在对象中。谁能帮我吗？我被困住了!

Sub GetFromOutlook()

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim olItems As Outlook.Items
Dim myItems As Outlook.Items
Dim DateStr As Date
Dim DateEnd As Date
Dim oOlResults As Object

Dim DateToCheck As String
Dim DateToCheck2 As String
Dim DateToCheck3 As String

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")

Dim olShareName As Outlook.Recipient
Set olShareName = OutlookNamespace.CreateRecipient("Mailbox.sharedmailbox@example.ca")
Set Folder = OutlookNamespace.GetSharedDefaultFolder(olShareName, olFolderInbox).Folders("sub1").Folders("sub2")
Set olItems = Folder.Items


'DateStr = 1/16/2018
'DateEnd = 1/17/2018

DateStr = Format(Range("From_Date").Value, "DDDDD HH:NN")
DateEnd = Format(Range("To_Date").Value, "DDDDD HH:NN")

'DateStr = DateAdd("d", -1, DateStr)
'DateEnd = DateAdd("d", 1, DateEnd)

DateToCheck = "[ReceivedTime] > """ & DateStr & """"
DateToCheck2 = "[ReceivedTime] <= """ & DateEnd & """"
DateToCheck3 = "[SenderName] = ""no-reply@example.com"""

Set myItems = olItems.Restrict(DateToCheck)
Set myItems = myItems.Restrict(DateToCheck2)
Set myItems = myItems.Restrict(DateToCheck3)

i = 1

For Each myitem In myItems
    ' MsgBox myitem.ReceivedTime

     Range("eMail_subject").Offset(i, 0).Value = myitem.Subject
     Range("eMail_date").Offset(i, 0).Value = myitem.ReceivedTime

     i = i + 1

Next myitem

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing


End Sub

Answer 1

如果您丢失了最近的邮件，请在一天后设置 DateEnd，没有时间。这应该计算到一天的开始时间 00:00。

Sub GetFromOutlook()

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant

Dim i As Integer

Dim olItems As Outlook.Items
Dim myItems As Outlook.Items
Dim myitem As Object

Dim DateStr As String
Dim DateEnd As String

Dim oOlResults As Object

Dim DateToCheck As String
Dim DateToCheck2 As String
Dim DateToCheck3 As String

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")

Dim olShareName As Outlook.Recipient
'Set olShareName = OutlookNamespace.CreateRecipient("Mailbox.sharedmailbox@example.ca")
'Set Folder = OutlookNamespace.GetSharedDefaultFolder(olShareName, olfolderinbox).Folders("sub1").Folders("sub2")

' for my testing
Set Folder = OutlookNamespace.getdefaultfolder(olfolderinbox)

Set olItems = Folder.Items

DateStr = "2018-01-16"
Debug.Print DateStr

' User input DateEnd without a time
DateEnd = "2018-01-17"
Debug.Print DateEnd

' Calculated DateEnd is the beginning of the next day
DateEnd = DateAdd("d", 1, DateEnd)
' This is 2018-01-18 00:00
Debug.Print DateEnd

DateToCheck = "[ReceivedTime] > """ & DateStr & """"
Debug.Print vbCr & "Filter 1: " & DateToCheck

Set myItems = olItems.Restrict(DateToCheck)

For Each myitem In myItems
    Debug.Print myitem.ReceivedTime & ": " & myitem.Subject
Next myitem

'DateToCheck2 = "[ReceivedTime] <= """ & DateEnd & """"
DateToCheck2 = "[ReceivedTime] < """ & DateEnd & """"
Debug.Print vbCr & "Filter 2: " & DateToCheck2

Set myItems = myItems.Restrict(DateToCheck2)

For Each myitem In myItems
    Debug.Print myitem.ReceivedTime & ": " & myitem.Subject
Next myitem

DateToCheck3 = "[SenderName] = ""no-reply@example.com"""
Debug.Print vbCr & "Filter 3: " & DateToCheck3

Set myItems = myItems.Restrict(DateToCheck3)

For Each myitem In myItems
    Debug.Print myitem.ReceivedTime & ": " & myitem.Subject
Next myitem

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

End Sub