每月邮件的 DASL 过滤器还返回上个月最后一天的项目

Question

我正在使用 DASL 过滤器来搜索标记为上个月已完成的邮件。

它还返回上个月最后一天标记的项目（因此我为 9 月过滤器获取了一些 8 月项目）。另外，如果有时间偏移，我不确定是否会提取所有在 9 月标记的项目（来自 9 月最后一天的项目）。

我猜这与应用程序中的标志时间和服务器上存储的时间之间的时间差有关。

Option Explicit
Option Base 1
Sub LoopInFolder()
    With Application
       .EnableEvents = False
       .ScreenUpdating = False
    End With

    Dim oa As Outlook.Application
    Dim om As Outlook.MailItem
    Dim m As Outlook.Namespace
    Dim f As Outlook.Folder
    Dim i As Object
    Dim ws As Worksheet
    Dim mcount As Byte
    Dim mailboxes(1 To 3) As Variant
    
    Set oa = New Outlook.Application
    Set m = oa.GetNamespace("MAPI")
    
    Set mailboxes(1) = 'folders
    ThisWorkbook.Activate
    mcount = 1

    For Each ws In Worksheets
        With ws
            .Cells.Clear
            .Activate
            .Range("A1").Value = "Sender name"
            .Range("B1").Value = "Mail title"
            .Range("C1").Value = "Category"
            .Range("D1").Value = "Processed by"
            .Range("E1").Value = "Date received"
            .Range("F1").Value = "Completed date"
            .Range("A2").Activate
        End With
        For Each i In mailboxes(1).Items.Restrict("@SQL=%lastmonth(""http://schemas.microsoft.com/mapi/proptag/0x10910040"")%")
            If i.Class = 43 Then
                ActiveCell.Value = i.SenderName
                ActiveCell.Offset(0, 1) = i.Subject
                ActiveCell.Offset(0, 2) = i.Categories
                ActiveCell.Offset(0, 3) = i.Categories
                ActiveCell.Offset(0, 4) = i.ReceivedTime
                ActiveCell.Offset(0, 5) = i.TaskCompletedDate
            End If
            ActiveCell.Offset(1, 0).Activate
        Next
        mcount = mcount + 1
    Next
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

End Sub

Answer 1

限制过滤器可以这样构建：

Sub LoopInFolder_UTC()

' https://stackoverflow.com/questions/48308994/using-restrict-method-for-emails-within-a-specified-date

    Dim olApp As outlook.Application
    Dim olFolder As outlook.Folder
    
    Dim olItems As outlook.Items
    Dim myItems As outlook.Items
    Dim myitem As Object
    
    Dim myFolder As outlook.Folder
    
    Dim firstDayOfLastMonth As Long
    Dim lastDayOfOfLastMonth As Long
    
    Dim firstDayOfCurrentMonth As Long
    
    Dim myUTC As Long
    
    Dim DateStart As String
    Dim DateEnd As String
    
    Dim filter1 As String
    Dim filter2 As String
    Dim filter3 As String
    
    Set olApp = New outlook.Application
    Set myFolder = Session.GetDefaultFolder(olFolderInbox)
    
    Set olItems = myFolder.Items
    
    Debug.Print "Today is " & Date
    
    ' https://stackoverflow.com/questions/15430035/how-to-get-start-and-end-of-previous-month-in-vb
    lastDayOfOfLastMonth = DateSerial(Year(Date), Month(Date), 0)
    Debug.Print "lastDayOfOfLastMonth: " & lastDayOfOfLastMonth
    Debug.Print "lastDayOfOfLastMonth: " & Format(lastDayOfOfLastMonth, "yyyy-mm-dd hh:mm AM/PM")
    
    firstDayOfLastMonth = lastDayOfOfLastMonth - day(lastDayOfOfLastMonth) + 1
    Debug.Print "firstDayOfLastMonth.: " & firstDayOfLastMonth
    Debug.Print "firstDayOfLastMonth.: " & Format(firstDayOfLastMonth, "yyyy-mm-dd hh:mm AM/PM")
    DateStart = Format(CDate(firstDayOfLastMonth), "yyyy-mm-dd hh:mm AM/PM")
    
    ' DateEnd is the beginning of the next day after applicable period
    firstDayOfCurrentMonth = DateAdd("d", 1, lastDayOfOfLastMonth)
    DateEnd = Format(CDate(firstDayOfCurrentMonth), "yyyy-mm-dd hh:mm AM/PM")
    
    Debug.Print
    Debug.Print "** Dates not adjusted **"
    Debug.Print "DateStart: " & DateStart
    Debug.Print "DateEnd..: " & DateEnd
    
    filter1 = "[ReceivedTime] > """ & DateStart & """"
    Debug.Print vbCr & "filter1: " & filter1
    
    Set myItems = olItems.Restrict(filter1)
    Debug.Print myItems.count
    
    filter2 = "[ReceivedTime] < """ & DateEnd & """"
    Debug.Print vbCr & "filter2: " & filter2
    Set myItems = myItems.Restrict(filter2)
    Debug.Print myItems.count

    ' old FlagStatus documentation
    ' https://docs.microsoft.com/en-us/previous-versions/office/developer/office-2010/bb644164(v=office.14)
    
    ' FlagStatus: Deprecated - replaced by FlagRequest
    ' 0 - olNoFlag       - FlagRequest text none
    ' 1 - olFlagComplete - FlagRequest text unchanged
    ' 2 - olFlagMarked   - FlagRequest text default is "Follow up"
    
    filter3 = "[FlagStatus] = 1"
    ' For testing - to get more results
    'filter3 = "[FlagStatus] <> 0"
    'filter3 = "[FlagStatus] = 0"
    Debug.Print vbCr & "filter3: " & filter3
    Set myItems = myItems.Restrict(filter3)
    Debug.Print myItems.count
    
    For Each myitem In myItems
        Debug.Print myitem.ReceivedTime & ": " & myitem.subject
    Next myitem
    
    ' ** UTC adjustment **
    Debug.Print
    Debug.Print "** UTC adjustment **"
    myUTC = 4 ' change to your own
    
    DateStart = Format(DateAdd("h", -myUTC, CDate(firstDayOfLastMonth)), "yyyy-mm-dd hh:mm AM/PM")
    Debug.Print "DateStart: " & DateStart

    ' DateEnd is the beginning of the next day after applicable period
    DateEnd = Format(DateAdd("h", -myUTC, CDate(firstDayOfCurrentMonth)), "yyyy-mm-dd hh:mm AM/PM")
    Debug.Print "DateEnd..: " & DateEnd

    Set olItems = myFolder.Items
    filter1 = "[ReceivedTime] > """ & DateStart & """"
    Debug.Print vbCr & "filter1: " & filter1
    Set myItems = olItems.Restrict(filter1)
    Debug.Print myItems.count
    
    filter2 = "[ReceivedTime] < """ & DateEnd & """"
    Debug.Print vbCr & "filter2: " & filter2
    Set myItems = myItems.Restrict(filter2)
    Debug.Print myItems.count
    
    Debug.Print vbCr & "filter3: " & filter3
    Set myItems = myItems.Restrict(filter3)
    Debug.Print myItems.count
    
    For Each myitem In myItems
        Debug.Print myitem.ReceivedTime & ": " & myitem.subject
    Next myitem

End Sub

过滤器可以合并为一个，但这样更容易跟踪和调试。