用于转发电子邮件的宏/脚本，将其拖入Outlook子文件夹以将其移动到新文件夹 [英] Macro/Script to forward emails dragged into a Outlook subfolder to move it to new folder

问题描述

你可以帮我解决这个过程中的Outlook宏/脚本吗？



我在收件箱下有3个子文件夹，A_Type电子邮件文件夹，B_Type电子邮件文件夹和转发的电子邮件文件夹

Can you help me with the Outlook macro/script on this process?

I have 3 sub folders under inbox, A_Type Email folder, B_Type Email folder and Forwarded Emails folder

每当我将电子邮件拖到A_Type电子邮件文件夹或B_Type电子邮件文件夹时，电子邮件将自动转发到特定的电子邮件地址，之后它将转移到转发的电子邮件文件夹自动？



感谢您的帮助！我真的很感激。

Whenever I drag emails to either A_Type Email folder or B_Type Email folder, the email will automatically forwarded to a specific emails address and after that it will move to Forwarded Emails folder automatically?

Thank you for your assistance! I really appreciate it.

推荐答案

将以下代码放在ThisOutlookSession模块中。检查文件夹名称，收件人详细信息和消息文本是否正确，然后在关闭编辑器之前，运行宏'Application_StartUp'。

Put the following code in the ThisOutlookSession module. Check the folder names, recipient details and message texts are correct, then before closing the editor, run the Macro 'Application_StartUp'.

然后当您将项目移动到"A_Type电子邮件"或"B_Type电子邮件"时，邮件将通过覆盖邮件转发给指定的收件人，然后移到第三个命名文件夹。

Then when you move item(s) to either 'A_Type Email' or 'B_Type Email', the message will be forwarded to the named recipient with the covering message, then moved to the third named folder.

Option Explicit
Private WithEvents MoveItems_A As Outlook.Items
Private WithEvents MoveItems_B As Outlook.Items

Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set MoveItems_A = olNS.GetDefaultFolder(olFolderInbox).folders("A_Type Email").Items
    Set MoveItems_B = olNS.GetDefaultFolder(olFolderInbox).folders("B_Type Email").Items
lbl_Exit:
    Exit Sub
End Sub

Private Sub MoveItems_A_ItemAdd(ByVal item As Object)
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim oMail As Outlook.MailItem
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    'On Error GoTo ErrorHandler
    If item.Class = olMail Then
        Set oMail = item.Forward
        With oMail
            .To = "[e-mail]"        'The recipient of the forwarded message
            .BodyFormat = olFormatHTML
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Range(0, 0)
            oRng.Text = "The accompanying message text"
            .Display
            .sEnd        'Restore after testing
        End With
        MoveToFolder item, _
                     olNS.GetDefaultFolder(olFolderInbox).folders("A_Type Email"), _
                     olNS.GetDefaultFolder(olFolderInbox).folders("Forwarded Emails")
    End If
lbl_Exit:
    Set oMail = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    GoTo lbl_Exit
End Sub

Private Sub MoveItems_B_ItemAdd(ByVal item As Object)
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim oMail As Outlook.MailItem
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    'On Error GoTo ErrorHandler
    If item.Class = olMail Then
        Set oMail = item.Forward
        With oMail
            .To = "[e-mail]"        'The recipient of the forwarded message
            .BodyFormat = olFormatHTML
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Range(0, 0)
            oRng.Text = "The accompanying message text"
            .Display
            .sEnd        'Restore after testing
        End With
        MoveToFolder item, _
                     olNS.GetDefaultFolder(olFolderInbox).folders("B_Type Email"), _
                     olNS.GetDefaultFolder(olFolderInbox).folders("Forwarded Emails")
    End If
lbl_Exit:
    Set oMail = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    GoTo lbl_Exit
End Sub

Sub MoveToFolder(olItem As Object, Source As Folder, Target As Folder)
Dim olNS As Outlook.NameSpace
Dim olMsg As Outlook.MailItem
Dim i As Long
    On Error Resume Next
    Set olNS = Application.GetNamespace("MAPI")
    Set Target = olNS.GetDefaultFolder(olFolderInbox).folders(Target)
    If olItem.DefaultItemType = olMailItem Then
        olItem.Move Target
    End If
    Source.Items(1).Delete
    Set olNS = Nothing
lbl_Exit:
    Exit Sub
End Sub

这篇关于用于转发电子邮件的宏/脚本，将其拖入Outlook子文件夹以将其移动到新文件夹的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！