Question

我正在创建一个宏来按主题收到电子邮件，并在我们的团队共享框中收到日期。我的问题是，一旦我选择了日期（例如，从1/16/2018到1/17/2018），只有少数电子邮件存储在对象中。在下面的屏幕截图中，我有9个项目应用了限制方法。它应该是在18/16/2018之后收到的14项电子邮件（截图中的右侧Outlook邮件），但是5个电子邮件不存储在对象中。谁能帮我吗？我是STUCK！

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

Answer 2

在解释我的评论时，您可以尝试使用以下注意事项：

收到日期，datereceived以UTC表示。因此，您需要根据UTC调整时间。在我的情况下它是UTC8所以我需要提前8小时调整_{（注意：没有文档来支持这个，但是当我做了我的时候测试时，以UTC表示。
可能是也可能并非总是如此。}
日期应表示为here所述的字符串。

虽然日期和时间通常以日期格式存储，但查找和限制方法要求将日期和时间转换为字符串表示。

示例：

mydate = Format(Now,"\'m/d/yyy hh:mm AM/PM\'") '/* will give '1/23/2018 01:36 PM' */

sendername可能包含电子邮件地址或电子邮件名称。

Sub stancial() Dim olItems As Outlook.Items Dim olFolder As Outlook.Folder Dim olNS As Outlook.NameSpace Dim olEmail As Outlook.MailItem Dim i As Long Dim efilter As String, startdt As String, endindt As String, _ myUTC As Integer, sentby As String myUTC = 8 '/* this is your UTC, change to suit (in my case 8) */ startdt = Format(DateAdd("h", -myUTC, _ CDate("1/18/2018 12:00 PM")), "\'m/d/yyyy hh:mm AM/PM\'") endindt = Format(DateAdd("h", -myUTC, _ CDate("1/18/2018 4:00 PM")), "\'m/d/yyyy hh:mm AM/PM\'") sentby = "'john.doe@email.com'" '/* can be sendername, "doe, john" */ Set olNS = Application.GetNamespace("MAPI") Set olFolder = olNS.GetDefaultFolder(olFolderInbox) '/* filter in one go, where datereceived is 'expressed in UTC (Universal Coordinated Time) */ efilter = "@SQL= (urn:schemas:httpmail:sendername = " & sentby & _ " And (urn:schemas:httpmail:datereceived >= " & startdt & _ " And urn:schemas:httpmail:datereceived <= " & endindt & "))" Set olItems = olFolder.Items.Restrict(efilter) With olItems For i = .Count To 1 Step -1 '/* starting from most recent */ If TypeOf .Item(i) Is MailItem Then Set olEmail = .Item(i) Debug.Print olEmail.Subject, olEmail.ReceivedTime End If Next End With End Sub

Answer 3

您的代码仅使用DateToCheck3限制 - 您的代码会忽略其他两个。如果要组合多个限制，请使用AND运算符将它们组合成单个查询。

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

3 个答案: