根据主题中的关键字将已发送的邮件复制到文件夹中 [英] Copy sent mail to folder based on key words in subject

问题描述

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

When I send an email which contains the word XYZ in the subject, I want Outlook to copy that email in the folder XY including the sent-date and marked as read.

我发现了两种方法-均无效:

I found two approaches – both not working:

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 & "[e-mail]"      
    End If
           
End Sub

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

Problems approach A:
The mail items is copied correctly, however the send date and time is blank, as the items has not yet been sent.

问题方法B:
添加了新地址，但是当所有已知地址都替换为用户友好"名称时，我收到一条奇怪的消息，即发件人(TO)无法再解析.因此，邮件将不会被发送.此外，我将需要添加手动过滤器-相当难看.

Problems approach B:
The new address is added, however as all known addresses are replaced by "user-friendly" names, I get a weird message, that the sender (TO) cannot be resolved any more. Thus the mail will not be sent. Furthermore I would need to add manual filters – which is rather ugly.

一般思想

1. 我想在发送文件夹中保留副本.因此扫描每天发送文件夹会在XY文件夹中导致大量重复同一封邮件.
2. 使用Mailitem.SaveMyPersonalItems属性只会将邮件移动到XY文件夹中，而不会将副本保留在已发送文件夹中.
3. 可能是Items.ItemAdd事件可能是一个解决方案，但我没有还不了解如何检查是否有新项目添加到了发送文件夹.
4. Outlook的内置过滤器允许复制已发送的邮件将包含"XYZ"的电子邮件发送到文件夹"XY".但是，不可能将其标记为已读.

推荐答案

项添加在任何文件夹上的作用相同.

Item Add works the same on any folder.

对于ThisOutlookSession模块:

For the ThisOutlookSession module:

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

这篇关于根据主题中的关键字将已发送的邮件复制到文件夹中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！