Outlook VBA-在子文件夹之间批量移动电子邮件

我通常需要将相当数量的电子邮件（150+）从一个子文件夹移动到另一个子文件夹。邮箱中有许多我执行此任务的文件夹。这似乎是一个很容易编写的宏，但我所做的要比Ctrl+a拖动到目标文件夹慢得多

我已经回顾了以前有关移动Outlook电子邮件和Microsoft文档的问题，但我无法找出如何以快速可靠的方式完成移动电子邮件。如果您能告诉我哪里出了问题，以及是否有VBA之外的其他解决方案，我将不胜感激

我现在的代码如下。我的最终目标是循环浏览文件夹名称列表（而不是选择文件夹）

提前谢谢

Sub MoveEmailsToDone()

On Error Resume Next

Dim ns As Outlook.NameSpace
Dim AnalystFolder As Outlook.MAPIFolder
Dim MoveToFolder As Outlook.MAPIFolder

Set ns = Application.GetNamespace("MAPI")

Set AnalystFolder = Application.ActiveExplorer.CurrentFolder
Set MoveToFolder = ns.Folders("username@domain.com").Folders(AnalystFolder.Name & "-DONE")

For i = AnalystFolder.Items.Count To 1 Step -1
    AnalystFolder.Items(i).Move MoveToFolder
Next i

Set ns = Nothing
Set AnalystFolder = Nothing
Set MoveToFolder = Nothing

End Sub

---

根据经验，移动和删除都很慢

2003年7月7日
下面的代码循环遍历指定文件夹中的每个邮件项目 并将项目移动到另一个文件夹。1100件物品需要更多的时间 超过5分钟。当我选择全部并移入时，移动速度不会那么慢 用户界面

Outlook使用扩展MAPI实现移动操作，即
IMAPIFolder:：CopyMessages（）接受EntryId列表，因此它不
需要打开每条消息。存储提供商在上完成整个操作
服务器没有来回发送大量数据，这在
你运行你的代码

德米特里·斯特雷布列琴科

DoEvents允许您在代码运行时使用Outlook

For i = AnalystFolder.Items.Count To 1 Step -1

    DoEvents    
    AnalystFolder.Items(i).Move MoveToFolder      

Next i

MsgBox "MoveEmailsToDone is finally done."

---

根据经验，移动和删除都很慢

2003年7月7日
下面的代码循环遍历指定文件夹中的每个邮件项目 并将项目移动到另一个文件夹。1100件物品需要更多的时间 超过5分钟。当我选择全部并移入时，移动速度不会那么慢 用户界面

Outlook使用扩展MAPI实现移动操作，即
IMAPIFolder:：CopyMessages（）接受EntryId列表，因此它不
需要打开每条消息。存储提供商在上完成整个操作
服务器没有来回发送大量数据，这在
你运行你的代码

德米特里·斯特雷布列琴科

DoEvents允许您在代码运行时使用Outlook

For i = AnalystFolder.Items.Count To 1 Step -1

    DoEvents    
    AnalystFolder.Items(i).Move MoveToFolder      

Next i

MsgBox "MoveEmailsToDone is finally done."