Outlook Macro，它将复制我标记的电子邮件并将其放置在文件夹中 [英] Outlook Macro that will copy an email I flag and put it in a folder

问题描述

如何移动我标记的电子邮件副本并将其放置在文件夹中?

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

例如，John Doe给我发送了一封电子邮件，我对其进行了标记，原始电子邮件保留在我的收件箱中，但是电子邮件的副本进入了一个名为 "Follow Up" 的文件夹中.有人能帮我吗?

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?

下面的代码非常接近我想要的代码，但是它会将原始电子邮件移至该文件夹而不是副本.它也没有针对已标记的电子邮件.

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

推荐答案

我认为这是您要尝试的操作，将以下代码添加到 ThisOutlookSession 并然后重新启动Outlook.

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

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

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

按 Alt+F11

Press Alt+F11

双击 ThisOutlookSession 并将代码粘贴到其中，然后重新启动Outlook并标记邮件项目.

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

这篇关于Outlook Macro，它将复制我标记的电子邮件并将其放置在文件夹中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！