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）无法再解析。因此邮件将不会被发送。此外，我需要添加手动过滤器 - 这是相当丑陋的。

一般性想法

我想在send文件夹中留下副本。因此扫描每日发送文件夹将导致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

试试这个

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 3

如果您在“已发送邮件”文件夹中不需要副本，则只需设置void Start() { if (someBoolean) { /* * Do My Code which could be a lot * */ } }属性 - Outlook会在项目发送后将该项目移动到该文件夹。

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

VBA根据主题中的关键词将邮件发送到文件夹

4 个答案: