根据主题中的关键字将已发送邮件复制到文件夹

Question

当我发送一封主题中包含单词 XYZ 的电子邮件时，我希望 Outlook 将该电子邮件复制到文件夹 XY 中，包括发送日期并标记为已读。

我发现了两种方法——都不起作用：

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If TypeName(Item) <> "MailItem" Then Exit Sub
       
    ' ~~> Search for Subject
    Set ol = New Outlook.Application
    Set olns = ol.GetNamespace("MAPI")
    Set myFolder = olns.GetDefaultFolder(olFolderInbox) ' inbox 
    Set XYFolder = myFolder.Folders("XY")' desired destination folder
       
    If InStr(1, Item.Subject, "XYZ", vbTextCompare) Then
    
        ‘ ~~ approach A: copy the object ~~~ 
        Set CopiedItem = Item.Copy ' create a copy 
        CopiedItem.Move XYFolder ' moce copy to folder 
        ' Set CopiedItem.SendOn = CopiedItem.CreationTime '<- not working, write protected 
    
        ‘ ~~ approach B: send me a copy (includes using filters afterwards )~~~
        Item.CC = Item.CC & "my.name@company.com"      
    End If
           
End Sub

问题处理方法A：
邮件项目已正确复制，但发送日期和时间为空，因为项目尚未发送。

问题方法B：
添加了新地址，但是由于所有已知地址都被“用户友好”名称替换，我收到一条奇怪的消息，即无法再解析发件人 (TO)。因此邮件将不会发送。此外，我需要添加手动过滤器——这非常难看。

总体思路

我想在发送文件夹中留下一份副本。从而扫描每天发送文件夹会导致 XY 文件夹中出现大量重复项相同的邮件。
使用 Mailitem.SaveMyPersonalItems 属性将仅在 XY 文件夹中移动邮件，但不会在已发送文件夹中留下副本。
可能 Items.ItemAdd 事件可能是一个解决方案，但我没有但了解如何检查是否有新项目添加到已发送文件夹。
outlook内置过滤器允许复制已发送包含“XYZ”的电子邮件到文件夹“XY”。然而这是不可能的将它们标记为已读。

Answer 1

项目添加对任何文件夹都一样。

对于 ThisOutlookSession 模块：

Option Explicit

Private WithEvents snItems As Items

Private Sub Application_Startup()
    '   default local Sent Items folder
    Set snItems = Session.GetDefaultFolder(olFolderSentMail).Items 
End Sub

Private Sub snItems_ItemAdd(ByVal item As Object) 

    Dim myFolder as Folder
    Dim XYFolder as Folder
    Dim CopiedItem as mailitem

    If TypeName(item) = "MailItem" Then

        Set myFolder = Session.GetDefaultFolder(olFolderInbox) ' inbox 
        Set XYFolder = myFolder.Folders("XY")' desired destination folder

        If InStr(1, Item.Subject, "XYZ", vbTextCompare) Then

            On Error Resume Next
            ' Appears CopiedItem is considered
            '  an item added to Sent Items folder
            ' Code tries to run more than once.
            ' It would be an endless loop
            '  but that item has been moved.
            '
            ' Skip all lines on the second pass.
            Set CopiedItem = item.copy ' create a copy
            CopiedItem.UnRead = True
            CopiedItem.Move XYFolder ' move copy to folder
            On Error GoTo 0

        End If

    End If

ExitRoutine:
    Set myFolder = Nothing
    Set XYFolder = Nothing
    Set CopiedItem = Nothing

End Sub

Answer 2

如果您不需要“已发送邮件”文件夹中的副本，只需设置 MailItem.SaveSentMessageFolder 属性 - Outlook 会在邮件发送后将其移至该文件夹。

Answer 3

试试这个

Sub CopyMailFromSentFolder()
    Dim oNS As Outlook.Namespace
    Dim oDefaultFolder As Outlook.MAPIFolder
    Dim oSentFolder As Outlook.MAPIFolder
    Dim oDestinationFolder As Outlook.MAPIFolder
    Dim oItems As Outlook.Items
    Dim oDestItems As Outlook.Items
    Dim oItemToCopy As MailItem
    Dim intCounter, intSecCounter As Integer
    Dim bolItemFound As Boolean

    Set oNS = GetNamespace("MAPI")
    Set oDefaultFolder = oNS.GetDefaultFolder(olFolderInbox)
    Set oSentFolder = oNS.GetDefaultFolder(olFolderSentMail)
    Set oItems = oSentFolder.Items

    For intCounter = 1 To oItems.Count
        If InStr(1, oItems(intCounter).Subject, "testing") > 0 Then 'And oItems(intCounter).Unread = True Then

            Set oDestinationFolder = oDefaultFolder.Folders("Just Testing")
            Set oDestItems = oDestinationFolder.Items
            bolItemFound = False

            For intSecCounter = 1 To oDestItems.Count
                If oDestItems(intSecCounter).Subject = oItems(intCounter).Subject And oDestItems(intSecCounter).SentOn = oItems(intCounter).SentOn Then
                    bolItemFound = True
                    Exit For
                End If
            Next
            If Not bolItemFound Then
                Set oItemToCopy = oItems(intCounter).Copy
                oItemToCopy.Move oDestinationFolder
                Set oItemToCopy = Nothing
            End If
            Set oDestinationFolder = Nothing
            Set oDestItems = Nothing

            'oItems(intCounter).Unread = False
        End If
    Next

    Set oNS = Nothing
    Set oDefaultFolder = Nothing
    Set oSentFolder = Nothing
    Set oItems = Nothing

End Sub

这应该避免复制重复项。尝试将其添加到 Application_ItemSend。不确定它是否会减慢发送过程，但它会给你想要的结果

Answer 4

根据 niton 的回答，我更改了代码，以便它可以处理多个文件夹。准备好 CnP。感谢所有贡献者！

Option Explicit

Private WithEvents snItems As Items

Private Sub Application_Startup()
    '   default local Sent Items folder
    Set snItems = Session.GetDefaultFolder(olFolderSentMail).Items
End Sub

Private Sub snItems_ItemAdd(ByVal item As Object)


    Dim myFolder As Folder
    Dim DestinationFolder As Folder     ' desired destination folder
    Dim CopiedItem As MailItem

    If TypeName(item) = "MailItem" Then

        Set myFolder = Session.GetDefaultFolder(olFolderInbox) ' inbox


        If InStr(1, item.Subject, "XYZ", vbTextCompare) Or _
           InStr(1, item.Subject, "BLA", vbTextCompare) Then

            On Error Resume Next
            ' Appears CopiedItem is considered an item added to Sent Items folder
            ' -> Code tries to run more than once.
            ' It would be an endless loop but that item has been moved.
            ' Skip all lines on the second pass.

            'define destination folder
            If InStr(1, item.Subject, "XYZ", vbTextCompare) Then
                Set DestinationFolder = myFolder.Folders("XY")

            ElseIf InStr(1, item.Subject, "BLA", vbTextCompare) Then
                Set DestinationFolder = myFolder.Folders("XBLA")

            End If

            ' copy the send mail to destination folder
            Set CopiedItem = item.Copy ' create a copy
            CopiedItem.Move DestinationFolder ' move copy to folder

            'Debugging
            'Debug.Print "mail w. subject: " & item.Subject & " copied to : " & DestinationFolder

            On Error GoTo 0

        End If

    End If

ExitRoutine:
    Set myFolder = Nothing
    Set DestinationFolder = Nothing
    Set CopiedItem = Nothing

End Sub

根据主题中的关键字将已发送邮件复制到文件夹

Copy sent mail to folder based on key words in subject

vba

email

outlook

outlook-2010