Vba 根据主题中的关键字将已发送邮件复制到文件夹
当我发送主题中包含单词XYZ的电子邮件时，我希望Outlook将该电子邮件复制到XY文件夹中，包括发送日期并标记为已读 我发现两种方法都不起作用：Vba 根据主题中的关键字将已发送邮件复制到文件夹,vba,email,outlook,outlook-2010,Vba,Email,Outlook,Outlook 2010,当我发送主题中包含单词XYZ的电子邮件时，我希望Outlook将该电子邮件复制到XY文件夹中，包括发送日期并标记为已读 我发现两种方法都不起作用： 私有子应用程序\u ItemSend（ByVal项作为对象，取消作为布尔值） 如果TypeName（Item）“MailItem”，则退出Sub “~~>搜索主题 Set ol=New Outlook.Application 设置olns=ol.GetNamespace（“MAPI”） 设置myFolder=olns.GetDefaultFolder
私有子应用程序\u ItemSend（ByVal项作为对象，取消作为布尔值）
如果TypeName（Item）“MailItem”，则退出Sub
“~~>搜索主题
Set ol=New Outlook.Application
设置olns=ol.GetNamespace（“MAPI”）
设置myFolder=olns.GetDefaultFolder（olFolderInbox）收件箱
设置XYFolder=myFolder.Folders（“XY”）'所需的目标文件夹
如果InStr（1，Item.Subject，“XYZ”，vbTextCompare），则
“~~方法A:复制对象~~”
Set CopiedItem=Item.Copy“创建副本”
CopiedItem。将XYFolder的moce副本移动到文件夹
“Set CopiedItem.SendOn=CopiedItem.CreationTime”Item Add在任何文件夹上的作用都是相同的
对于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
如果在“已发送邮件”文件夹中不需要副本，只需设置MailItem.SaveSentMessageFolder
属性-Outlook将在发送邮件后将其移动到该文件夹中 试试这个
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
这应该避免复制重复项。尝试将其添加到应用程序\u ItemSend。不确定它是否会减慢发送过程，但它会给您所需的结果根据尼顿的回答，我更改了代码，以便它可以处理多个文件夹。为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
是否可以使用Outlook中的规则将电子邮件复制到所需文件夹，然后使用一个仅查看此文件夹的宏将电子邮件标记为未读？@Zac是的，但这种方法消除了将未读邮件作为提醒保存在该子文件夹中的可能性。有点困惑，我以为你想将“XP”文件夹中的电子邮件标记为已读？请澄清，当您使用Outlook规则移动电子邮件时，您无法手动将其设置为读取？这就是问题所在吗？Outlook上有点生锈，但您可能需要在发送后将其从“已发送”文件夹中复制，如果未提取，您可以随时手动设置发送时间。@zac。对，我想把它们标记为已读。当与规则一起复制时，将标记为未读（不需要的结果）。也不希望将该文件夹中的所有电子邮件标记为未读，因为该文件夹中可能有来自其他发件人的一些电子邮件，我希望将其标记为未读，以获取代码。我试过了，但没有成功。我得到一个运行时错误-2147221241（80040107）和类似“客户端操作失败”（德语版本）的东西。调试器指向以下行：Set CopiedItem=item.Copy“创建副本”。不幸的是，我不理解这个问题。但是，只有60%的情况下会出现错误消息。在收到第一条错误消息之前，所有电子邮件都被正确复制。我添加了一个消息框，确认找到了XYZ。在每一条错误消息出现之前，消息框会出现两次（但只有一个副本放在XY文件夹中），此时会为“CopiedItem”调用itemAdd。也许有更优雅的东西，但我发现这个循环被打破了，通常避免在下一个错误恢复。谢谢！这项工作如预期（除了我不想将它们标记为未读-但这是一个简单的编辑）。伟大的我还将发布我的代码，即基于您的代码，处理多个文件夹。太好了，这很有效！谢谢但是，我仍然需要使用规则。。。如果只使用一个宏，而不是两个单独管理的步骤的组合，这将更加优雅。我已经更新了Sub，以从已发送项目
文件夹中移动项目。我还检查了未读
，因为当我测试这个时，一旦项目从已发送项目
文件夹中移动，它将保持为已读
项目。我把它放在那里作为评论，以防你得到不同的结果，需要将项目标记为未读
谢谢你的时间！但是有两个缺点：1）子系统仅手动运行（或在启动时，如果调用），2）每次子系统运行时，它都复制相同的电子邮件。因此，您的文件夹将从重复项中爆炸出来；）：）我们会到达那里的！。以上更新刚刚意识到您的问题有答案，所以请忽略我的更新。快乐编码