Vba 将电子邮件从邮箱移动到同一邮箱中早于x天或x年的特定文件夹

我希望将所有电子邮件（已发送和已接收）从邮箱（包括收件箱、子文件夹及其子文件夹、已发送邮件、子文件夹及其子文件夹）移动到同一邮箱（该文件夹位于名为old_mail的收件箱中）中超过x天或x年的特定文件夹中

我尝试过创建关于stackoverflow的规则和一些建议，但似乎都没有效果

我更喜欢VBA脚本，但任何帮助和解决方案都将被接受

先谢谢你

请参阅以下代码：

Sub A_Email_Filter()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String

Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)

'A subfolder under Inbox
Set objDestFolder = objSourceFolder.Folders("Old_Email")

For intCount = objSourceFolder.Items.Count To 1 Step -1
    Set objVariant = objSourceFolder.Items.Item(intCount)
    DoEvents
    If objVariant.Class = olMail Then

         intDateDiff = DateDiff("d", objVariant.SentOn, "01/01/2016")

        'Days old, adjust as needed.
        If intDateDiff > 2300 Then

          objVariant.Move objDestFolder

          'Count the # of items moved
           lngMovedItems = lngMovedItems + 1

        End If
    End If
Next

' Display the number of items that were moved.
MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objDestFolder = Nothing
End Sub

这似乎只适用于已发送的项目，但它不起作用，我需要移动所有已发送和已接收的项目，这些项目的日期早于定义的日期

我有下面的工作收件箱和发送邮件在同一时间现在

Sub A_Old_Email_Sent_Received()

   Dim myNameSpace As Outlook.NameSpace
   Set myNameSpace = Application.GetNamespace("MAPI")

   Dim myInbox As Outlook.Folder
   Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)

   Dim mySentbox As Outlook.Folder
   Set mySentbox = myNameSpace.GetDefaultFolder(olFolderSentMail)

   Dim myDestFolder As Outlook.Folder
   Set myDestFolder = myInbox.Folders("Old_Email")

   Dim myReceivedItems As Outlook.Items
   Set myReceivedItems = myInbox.Items

   Dim mySentItems As Outlook.Items
   Set mySentItems = mySentbox.Items

   Dim myItemCountInbox As Integer
   Dim myItemCountSentbox As Integer

   Dim myReceivedItem As Object
   Dim mySentItem As Object

   '### Received Email
   'Based on their Age -## days Old, Date
   Set myReceivedItem = myReceivedItems.Find("[SentOn] < '" & Format(DateAdd("d", -10, "24/04/2017"), "dd/mm/yyyy") & "'")
   'Get to work - Inbox
   While TypeName(myReceivedItem) <> "Nothing"
      myReceivedItem.Move myDestFolder
      Set myReceivedItem = myReceivedItems.FindNext
      myItemCountInbox = myItemCountInbox + 1
   Wend
   MsgBox "Number of received emails moved: " & myItemCountInbox, vbInformation, "Received Emails"

   '### Sent Email
   'Based on their Age -## days Old, Date
   Set mySentItem = mySentItems.Find("[SentOn] < '" & Format(DateAdd("d", -10, "24/04/2017"), "dd/mm/yyyy") & "'")
   'Get to work - Sent Items
   While TypeName(mySentItem) <> "Nothing"
      mySentItem.Move myDestFolder
      Set mySentItem = mySentItems.FindNext
      myItemCountSentbox = myItemCountSentbox + 1
   Wend
   MsgBox "Number of sent emails moved: " & myItemCountSentbox, vbInformation, "Sent Emails"
End Sub

Sub A_Old_Email_Sent_Received（）
将myNameSpace设置为Outlook.NameSpace
设置myNameSpace=Application.GetNamespace（“MAPI”）
将我的收件箱暗显为Outlook.Folder
设置myInbox=myNameSpace.GetDefaultFolder（olFolderInbox）
将mySentbox暗显为Outlook.Folder
设置mySentbox=myNameSpace.GetDefaultFolder（olFolderSentMail）
将myDestFolder暗显为Outlook.Folder
设置myDestFolder=myInbox.Folders（“旧电子邮件”）
将myReceivedItems暗显为Outlook.Items
设置myReceivedItems=myInbox.Items
将mySentItems设置为Outlook.Items
设置myEntItems=myEntBox.Items
将myItemCountInbox设置为整数
将myItemCountSentbox设置为整数
将myReceivedItem设置为对象
作为对象的Dim mySentItem
“####收到电子邮件
“根据他们的年龄-##天，日期
设置myReceivedItem=myReceivedItems.Find（“[SentOn]<”）和Format（日期添加（“d”），-10，“2017年4月24日”），“dd/mm/yyyy”和“”）
'开始工作-收件箱
而TypeName（myReceivedItem）“Nothing”
myReceivedItem。移动myDestFolder
设置myReceivedItem=myReceivedItems.FindNext
myItemCountInbox=myItemCountInbox+1
温德
MsgBox“移动的接收电子邮件数：&myItemCountInbox，vbInformation，“接收电子邮件”
“####发送电子邮件
“根据他们的年龄-##天，日期
设置mySentItem=mySentItems.Find（“[SentOn]<”）和Format（DateAdd（“d”），-10，“24/04/2017”），“dd/mm/yyyy”）和“”）
'开始工作-发送邮件
而TypeName（mySentItem）“Nothing”
mySentItem.Move mydest文件夹
设置mySentItem=mySentItems.FindNext
myItemCountSentbox=myItemCountSentbox+1
温德
MsgBox“移动的已发送电子邮件数：”&myItemCountSentbox，vbInformation，“已发送电子邮件”
端接头

不确定如何添加要循环的函数。

摘自MS，这将为您提供一个坚实的开端

将发件人名称为“SenderName”的邮件移动到“Old_Email”文件夹中：

---

编辑：您可以找到一个递归遍历文件夹及其子文件夹的函数。根据您的需要进行调整。

请发布您试用过的代码，并说明您的问题。@David G，我已经用我试用过的代码更新了问题。它不会移动任何消息，即使我在文件夹中发送和接收了2007年的电子邮件。我希望它检查收件箱中的所有文件夹、子文件夹及其子文件夹，并发送邮件，并将任何超过指定天数的邮件移动到收件箱中的“old_mail”文件夹。您是否尝试过将单个邮件从一个文件夹移到另一个文件夹？我尝试过，但根本不起作用。仅Msgbox在结尾处声明“移动了0条消息”。我正在使用Office 2013和Exchange Online，这两个版本应该没有太大区别。请参见下面的答案@David G，我也尝试过，但没有区别。请发布您尝试过的确切代码，发生了什么，没有发生什么。与您在上面发布的代码相同，将“SenderName”更改为“用户名”，以便接收电子邮件。现在请准确地告诉我发生了什么和没有发生什么。用“F8”按钮逐行检查代码。如果我尝试

设置myItem=myItems.Find（“[SenderName]='SenderName'）”）

它对发件人有效，只从任何子文件夹中移动收件箱中的所有项目，如果我在TypeName（myItem）“Nothing”和（DateDiff（“d”，myItem.SentOn，Now））>30时添加日期，则不起任何作用

Sub MoveItems() 
 Dim myNameSpace As Outlook.NameSpace 
 Dim myInbox As Outlook.Folder 
 Dim myDestFolder As Outlook.Folder 
 Dim myItems As Outlook.Items 
 Dim myItem As Object 

 Set myNameSpace = Application.GetNamespace("MAPI") 
 Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox) 
 Set myItems = myInbox.Items
 'specify the destination folder
 Set myDestFolder = myInbox.Folders("Old_Email")
 'specify the condition, change to date
 Set myItem = myItems.Find("[SenderName] = 'SenderName'") 
 While TypeName(myItem) <> "Nothing" 
 myItem.Move myDestFolder 
 Set myItem = myItems.FindNext 
 Wend 
End Sub

If (DateDiff("d", myItem.SentOn, Now)) > 7
   'move mail
End If