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 ，然后重新启动您的展望。

代码将自动移动已标记的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并标记您的邮件项目。