从上一个工作日移动电子邮件什么都不做

Posted 2021-04-05

我正在尝试整合Outlook VBA以查找上一个工作日（周一至周五）主要收件箱中的所有电子邮件，并将它们移动到我正在创建的新文件夹中。

我试图添加逻辑以跳过周六和周日。从今天是星期一开始，我应该从周五开始发送所有电子邮件。它成功创建了上周五日期的新文件夹，但它不会移动任何电子邮件。最后我查了一下，周五它确实移动了周四的项目。我很难确定为什么今天上周五的电子邮件不会移动？

我的问题是，任何人都可以确定为什么星期五的电子邮件根本没有被移动？

以下是我目前使用的代码：

Sub Move_Yesterdays_Emails()

'***Creates a new folder named yesterdays date under the inbox***

 Dim myNameSpace As Outlook.NameSpace
 Dim myFolder As Outlook.Folder
 Dim myNewFolder As Outlook.Folder
 Dim xDay As String
 Dim XDate As Date

    If Weekday(Now()) = vbMonday Then
        XDate = Date - 3
    Else
        XDate = Date - 1
    End If

 Set myNameSpace = Application.GetNamespace("MAPI")
 Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
 Set myNewFolder = myFolder.Folders.Add(XDate)

'***Releases memory***

 Set myNameSpace = Nothing
 Set myFolder = Nothing
 Set myNewFolder = Nothing

'***Finds all emails in the inbox from yesterday and moves them to the created folder***

    Dim myNameSpace As Outlook.NameSpace
    Dim Inbox As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim Item As Object
    Dim Filter As String
    Dim i As Long

        Filter = "[ReceivedTime] >= '" & _
              CStr(XDate) & _
             " 12:00AM' AND [ReceivedTime] < '" & _
              CStr(XDate) & " 12:00AM'"

        Debug.Print Filter

    Set myNameSpace = Application.GetNamespace("MAPI")
    Set Inbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items.Restrict(Filter)
        Items.Sort "[ReceivedTime]"

    For i = Items.Count To 1 Step -1
        DoEvents
        If TypeOf Items(i) Is MailItem Then
            Debug.Print Items(i)
            Set Item = Items(i)
            Item.Move Inbox.Folders(XDate)
        End If
    Next
End Sub

先感谢您。我今天想解决这个问题，所以我不必等到下周一才能再次尝试这种情况。

答案

你的代码有几个问题，我修复了一切，现在运行正常

主要错误：你的过滤器是

 [ReceivedTime] >= '15/06/2018 12:00AM' AND [ReceivedTime] < '15/06/2018 12:00AM'

所以基本上它没有搜索任何东西，因为它们之间的2个日期时间是相同的。你应该像这样制作你的过滤器

    Filter = "[ReceivedTime] >= '" & _
          CStr(XDate) & _
         " 12:00AM' AND [ReceivedTime] < '" & _
          CStr(XDate + 1) & " 12:00AM'"

你也遇到过Item.Move的问题。您应该在那里指定Outlook.Folder类型的对象

整个子变成了

Option Explicit

Sub Move_Yesterdays_Emails()


'***Creates a new folder named yesterdays date under the inbox***

 Dim myNameSpace As Outlook.NameSpace
 Dim myFolder As Outlook.Folder
 Dim myNewFolder As Outlook.Folder
 Dim xDay As String
 Dim XDate As Date

    If Weekday(Now()) = vbMonday Then
        XDate = Date - 3
    Else
        XDate = Date - 1
    End If

 Set myNameSpace = Application.GetNamespace("MAPI")
 Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
 Set myNewFolder = myFolder.Folders.Add(XDate)

'***Finds all emails in the inbox from yesterday and moves them to the created folder***

    'Dim myNameSpace As Outlook.NameSpace ---> DUPLICATE DECLARATION
    Dim Inbox As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim Item As Object
    Dim Filter As String
    Dim i As Long

        Filter = "[ReceivedTime] >= '" & _
              CStr(XDate) & _
             " 12:00AM' AND [ReceivedTime] < '" & _
              CStr(XDate + 1) & " 12:00AM'"

        Debug.Print Filter

    Set myNameSpace = Application.GetNamespace("MAPI")
    Set Inbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items.Restrict(Filter)
        Items.Sort "[ReceivedTime]"

    For i = Items.Count To 1 Step -1
        DoEvents
        If TypeOf Items(i) Is MailItem Then
            Debug.Print Items(i)
            Set Item = Items(i)
            Item.Move myNewFolder
        End If
    Next
End Sub