Question

我正在尝试将到达收件箱的邮件项目复制到其他文件夹。

它抛出错误-2147221241（80040107），但邮件已成功复制，只有脚本停止。

在调试时，此行突出显示：

Set myCopiedItem = Item.Copy

这是我的代码。

Public WithEvents objMails As Outlook.Items

Private Sub Application_Startup()
    Set objMails = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub objMails_ItemAdd(ByVal Item As Object)

    Dim msg As Outlook.MailItem
    Dim myCopiedItem As Outlook.MailItem
    Dim myNameSpace As Outlook.NameSpace
    Dim myFolder As Outlook.Folder
    Dim myNewFolder As Outlook.Folder

    If Item.Class = olMail Then
       Set msg = Item
       Set myCopiedItem = Item.Copy
       Set myNameSpace = Application.GetNamespace("MAPI")
       Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
       Set myNewFolder = myFolder.Folders("_tmp_copy_mail")
       myCopiedItem.Move myNewFolder
    End If

End Sub

Answer 1

经过不眠之夜，我找到了解决办法。显然这段代码

Set myCopiedItem = Item.Copy

制作传入邮件的副本并触发ItemAdd事件，并创建无限循环的电子邮件复制。因此错误。

解决方法是暂时停止监控ItemAdd进程，进行复制和移动，然后重新开始监控。

所以修改后的工作代码如下：

If Item.Class = olMail Then

   'disable itemAdd monitoring
   Set objMails = Nothing

   'do the work
   Set myCopiedItem = Item.copy
   Set myNameSpace = Application.GetNamespace("MAPI")
   Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
   Set myNewFolder = myFolder.Folders("_tmp_copy_mail")
   myCopiedItem.Move myNewFolder

   'enable again the monitoring
   Set objMails = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End If

ItemAdd中的复制方法抛出错误-2147221241（80040107）

1 个答案: