如何将默认收件箱中的每条未读邮件复制到共享文件夹？

Question

我正在尝试组织 10 多个不同的邮箱。

问题在于 UnreadMove。我希望每次 Outlook 打开时在默认收件箱中查找未读邮件，将其复制并将其中一份副本移动到共享收件箱中。

如果要移动一封邮件，它可以工作，但是当有更多邮件时，我会收到错误

“-2147221241 - 客户端操作失败”

或类似的东西。我的 Windows 不是英文的。

当我在失败窗口上按确定时，邮件仍然被复制并移动到正确的文件夹，所以我不知道错误是什么意思。有些邮件复制了两次，所以可能是错误的含义。

MoveAndCopy：收到的邮件被复制并发送到共享收件箱，并在原始文件夹中标记为已读（这有效）。
UnreadMove：应该是当 Outlook 有一段时间没有打开并且原始收件箱收到新邮件时使用。然后我希望复制未读的电子邮件，标记为已读，然后将副本发送到共享收件箱，不应将其标记为已读。

此 Outlook 会话

Private Sub Application_Startup()

Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace

Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")

Set Items = objNS.GetDefaultFolder(olFolderInbox).Items

End Sub

Private Sub Items_UnreadMove(ByVal Item As Object)

Dim msg As Outlook.MailItem

    If Item.Exists = True Then
        Set msg = Item
        Call UnreadMove(Item)
    End If
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)

On Error GoTo ErrorHandler
Dim msg As Outlook.MailItem

    If TypeName(Item) = "MailItem" Then
        Set msg = Item
        Call MoveAndCopy(Item)
    End If

ProgramExit:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description

Resume ProgramExit
End Sub

对于这两个模块：

Sub UnreadMove(Item As Outlook.MailItem)

Dim Inbox As Outlook.Folder
Dim ns As Outlook.NameSpace
Dim MailDest As Outlook.Folder
Dim CopiedItem As Outlook.MailItem

Set Inbox = ns.GetDefaultFolder(olFolderInbox)

For Each Item In Inbox
    If Item.UnRead = True Then
        Set CopiedItem = Item.Copy
        Item.UnRead = False
        Item.Save
        Set ns = Outlook.Application.GetNamespace("MAPI")
        Set MailDest = ns.Folders("myemail@test.com").Folders("MyInbox")
        CopiedItem.Move MailDest
    End If
Next Item

End Sub
Sub MoveAndCopy(Item As Outlook.MailItem)

Dim ns As Outlook.NameSpace
Dim MailDest As Outlook.Folder
Dim CopiedItem As Outlook.MailItem
    
    If Item.Class = olMail Then
        Set CopiedItem = Item.Copy
        Item.UnRead = False
        Item.Save
        Set ns = Outlook.Application.GetNamespace("MAPI")
        Set MailDest = ns.Folders("myemail@test.com").Folders("MyInbox")
        CopiedItem.Move MailDest
    End If
    
End Sub

Answer 1

UnreadMove 在受监控的文件夹中创建一个副本。它将调用Items_ItemAdd。 MoveAndCopy 也一样。

无论这是否是您现在看到的错误的原因，这应该可以满足您的要求。

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant

Private WithEvents monitoredItems As Items

Private Sub Application_Startup()
    UnreadMove
    Set monitoredItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub


Sub UnreadMove()

    Dim Inbox As folder
    Dim MailDest As folder
    Dim CopiedItem As MailItem

    Dim objItem As Object

    Set Inbox = Session.GetDefaultFolder(olFolderInbox)

    Set MailDest = Session.folders("myemail@test.com").folders("MyInbox")

    ' Copying invokes itemAdd
    ' If you run this manually,
    '   after setting up monitoredItems in startup
    '  - a trick to turn itemAdd off
    Set monitoredItems = Nothing

    '
    'For Each objItem In Inbox.Items
    
    '    If objItem.Class = olMail Then
    
    '        If objItem.UnRead = True Then
    '            Debug.Print objItem.subject
    '
    '            Set CopiedItem = objItem.copy
    '            objItem.UnRead = False
    '            objItem.Save
                        
    '            CopiedItem.Move MailDest
            
    '        End If
        
    '    End If
    
    'Next objItem

    ' If the For Each index is confused by copying and moving
    '  Then a reverse For Next is needed.
    '  A reverse loop works in all situations.
    Dim i As Long
    For i = Inbox.Items.count To 1 Step -1
    
        Set objItem = Inbox.Items(i)
    
        If objItem.Class = olMail Then
    
            If objItem.UnRead = True Then
                Debug.Print objItem.subject
            
                Set CopiedItem = objItem.copy
                objItem.UnRead = False
                objItem.Save
            
                CopiedItem.Move MailDest
            
            End If
        
        End If
    
    Next

    ' reset items to be monitored with itemAdd
    Set monitoredItems = Session.GetDefaultFolder(olFolderInbox).Items

End Sub

当您在受监控的文件夹中制作副本时，暂时停止监控。

Private Sub monitoredItems_ItemAdd(ByVal Item As Object)

    Dim msg As MailItem

    If TypeName(Item) = "MailItem" Then
        Set msg = Item
        Set monitoredItems = Nothing
        
        'Call MoveAndCopy(Item)
                
        Call MoveAndCopy(msg)
        ' or
        ' MoveAndCopy msg
        Set monitoredItems = Session.GetDefaultFolder(olFolderInbox).Items

    End If

End Sub

如果您希望更具体一些，您可以改为在 MoveAndCopy 中停止监控。