Outlook Macro that will copy an email I flag and p

问题:

How can I move copy of emails I flag and put them in a folder?

For example, John Doe sends me an email, I flag it, the original email stays in my inbox but a copy of the email goes into a folder called "Follow Up". Can someone help me?

EDIT:

The code below is extremely close to what I want but it's moving the original email to the folder instead of a copy. It's also not targeting the flagged email.

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

回答1:

I think this is what your trying to do, add the following code to ThisOutlookSession and then restart your outlook.

Code will automatically move copy of flagged 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

Press Alt+F11

double click ThisOutlookSession and paste the code in there, then restart your outlook and flag your mail item.