Vba 移动前一个工作日的电子邮件时什么也不做
我正在尝试将Outlook VBA整合在一起,以查找上一个工作日星期一星期五主收件箱中的所有电子邮件,并将它们移动到一个新文件夹中,我也正在创建该文件夹 我试图加入跳过周六和周日的逻辑。因为今天是星期一,我应该从星期五开始移动所有电子邮件。它成功地创建了上周五日期的新文件夹,但不移动任何电子邮件。我上次检查时,它在周五确实移动了周四的项目。我很难确定为什么它今天不会移动上周五的电子邮件 我的问题是,有人能确定为什么周五的邮件没有被移动吗 以下是我目前使用的代码:Vba 移动前一个工作日的电子邮件时什么也不做,vba,outlook,Vba,Outlook,我正在尝试将Outlook VBA整合在一起,以查找上一个工作日星期一星期五主收件箱中的所有电子邮件,并将它们移动到一个新文件夹中,我也正在创建该文件夹 我试图加入跳过周六和周日的逻辑。因为今天是星期一,我应该从星期五开始移动所有电子邮件。它成功地创建了上周五日期的新文件夹,但不移动任何电子邮件。我上次检查时,它在周五确实移动了周四的项目。我很难确定为什么它今天不会移动上周五的电子邮件 我的问题是,有人能确定为什么周五的邮件没有被移动吗 以下是我目前使用的代码: Sub Move_Yesterd
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'
你看到调试。打印项目了吗?@ThomasG不,我没有看到它们哇,谢谢你修复它!所以我的主要问题是,我错过了XDate+1,将第二个日期设置为第二天星期六……一旦你指出了这一点,这似乎是显而易见的。现在很有魅力。
Filter = "[ReceivedTime] >= '" & _
CStr(XDate) & _
" 12:00AM' AND [ReceivedTime] < '" & _
CStr(XDate + 1) & " 12:00AM'"
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