Outlook 宏将复制我标记的电子邮件并将其放入文件夹中

Question

如何移动我标记的电子邮件副本并将它们放入文件夹中？

例如，John Doe 给我发了一封电子邮件，我标记它，原始电子邮件保留在我的收件箱中，但电子邮件的副本进入名为 "Follow Up" 的文件夹。有人能帮我吗？

编辑：

下面的代码与我想要的非常接近，但它将原始电子邮件移动到文件夹而不是副本。它也不针对标记的电子邮件。

Sub FollowUp()
On Error Resume Next

Dim ns As Outlook.NameSpace
Dim moveToFolder As Outlook.MAPIFolder
Dim objItem As Outlook.MailItem



Set ns = Application.GetNamespace("MAPI")

'Define path to the target folder
Set moveToFolder = ns.Folders("MainFolder").Folders("Inbox").Folders("Follow Up")

If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox ("No item selected")
Exit Sub
End If

If moveToFolder Is Nothing Then
MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
End If

For Each objItem In Application.ActiveExplorer.Selection
If moveToFolder.DefaultItemType = olMailItem Then
  If objItem.Class = olMail Then
     objItem.Move moveToFolder
  End If
End If
Next

Set objItem = Nothing
Set moveToFolder = Nothing
Set ns = Nothing


End Sub

Answer 1

我认为这是您尝试做的事情，请将以下代码添加到 ThisOutlookSession，然后重新启动您的 Outlook。

代码将自动移动标记的 Mailitem 的副本

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
    Dim olNameSpace As Outlook.NameSpace
    Dim olFolder  As Outlook.MAPIFolder

    Set olNameSpace = Application.GetNamespace("MAPI")
    Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox) 
    Set Items = olFolder.Items
End Sub

Private Sub Items_ItemChange(ByVal Item As Object)
    Dim olNameSpace As Outlook.NameSpace
    Dim olFolder  As Outlook.MAPIFolder
    Dim olInbox  As Outlook.MAPIFolder
    Dim ItemCopy As MailItem

    Set olNameSpace = Application.GetNamespace("MAPI")
    Set olInbox = olNameSpace.GetDefaultFolder(olFolderInbox)
    Set olFolder = olInbox.Folders("Follow Up")

    If TypeOf Item Is Outlook.MailItem Then
        Debug.Print Item

        If Item.FlagStatus = olFlagMarked Then
            Set ItemCopy = Item.Copy ' Copy Flagged item
             ItemCopy.Move olFolder ' Move Copied item
        End If

        Set Item = Nothing
        Set ItemCopy = Nothing
    End If
End Sub

按Alt+F11

双击 ThisOutlookSession 并将代码粘贴到那里，然后重新启动 Outlook 并标记您的邮件项目。