Выберите папку (Входящие) и выполните макрос в электронной почте перемещены

Question

У меня есть макрос, который перемещает каждое электронное письмо из subfolder в папку «Входящие» и отлично работает!Но как я могу вызвать макрос для этой конкретной электронной почты, которая была перемещена?

Макрос для перемещения электронной почты:

Public Sub Mover_Email()
'   // Declare your Variables
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim olNs As Outlook.NameSpace
    Dim Item As Object
    Dim lngCount As Long
    Dim Items As Outlook.Items

    On Error GoTo MsgErr
'    Set Inbox Reference
    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = Application.Session.GetDefaultFolder(olFolderInbox).Folders("1 - Arquivos Temporarios")
    Set Items = Inbox.Items

'   // Loop through the Items in the folder backwards
    For lngCount = Items.count To 1 Step -1
        Set Item = Items(lngCount)

        Debug.Print Item.Subject

        If Item.Class = olMail Then
'           // Set SubFolder of Inbox
            Set SubFolder = olNs.GetDefaultFolder(olFolderInbox)
'           // Mark As Read
            Item.UnRead = False
'           // Move Mail Item to sub Folder
            Item.Move SubFolder
            'Call the macro for that email
            '************
            'Enter the macro here
            '************
        End If
    Next lngCount

MsgErr_Exit:
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set olNs = Nothing
    Set Item = Nothing

    Exit Sub

'// Error information
MsgErr:
    MsgBox "An unexpected Error has occurred." _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume MsgErr_Exit
End Sub

Я подумал, что выбрал папку «Входящие» и выполнилмакрос в этом письме мог бы работать, но я не знаю, как.

Если есть какое-то другое простое решение, я бы предпочел это (например, не выбирая Входящие).

Answer 1

Ссылка на письмо теряется при перемещении.

Создайте ссылку на перемещенное письмо с помощью Set movedItem = ….

Public Sub Move_first_then_Process_Email()

'   // Declare your Variables
    Dim Inbox As Folder
    Dim SubFolder As Folder
'    Dim olNs As NameSpace
    Dim Item As Object
    Dim lngCount As Long
    Dim Items As Items

    Dim movedItem As MailItem

'   Not when developing
'    On Error GoTo MsgErr

'    Set Inbox Reference
'   Not needed when using Session
'    Set olNs = GetNamespace("MAPI")

     Set Inbox = Session.GetDefaultFolder(olFolderInbox).Folders("1 - Arquivos Temporarios")
    Set Items = Inbox.Items

'   // Set target folder
    Set SubFolder = Session.GetDefaultFolder(olFolderInbox)

'   // Loop through the Items in the folder backwards
    For lngCount = Items.Count To 1 Step -1

        Set Item = Items(lngCount)

        Debug.Print "Subject of Item: " & Item.Subject

        If Item.Class = olMail Then
'
'           // Mark As Read
            Item.UnRead = False

'           // Move Mail Item to target folder
'               and create a reference to the moved item
            Set movedItem = Item.Move(SubFolder)

            'Call the macro for moved email
            '************
            display_Subject movedItem
            '************

        End If

    Next lngCount

MsgErr_Exit:
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set Item = Nothing

    Exit Sub

'// Error information
MsgErr:
    MsgBox "An unexpected Error has occurred." _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume MsgErr_Exit
End Sub

Private Sub display_Subject(ByRef mvItem As Object)
    If mvItem.Class = olMail Then
        Debug.Print "Subject of movedItem: " & mvItem.Subject
        Debug.Print
    Else
        Debug.Print "Not a mailitem."
    End If
End Sub

Answer 2

Работа с Метод NameSpace.PickFolder (Outlook)

Пример

Set Inbox = Application.Session.PickFolder

Вы также можете установить Subfolder на PickFolder, но переместить его за пределы цикла

Пример

Option Explicit
Public Sub Mover_Email()
'   // Declare your Variables
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim olNs As Outlook.NameSpace
    Dim Item As Object
    Dim lngCount As Long
    Dim Items As Outlook.Items

    On Error GoTo MsgErr
'    Set Inbox Reference
    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = Application.Session.PickFolder

    Set Items = Inbox.Items

'   // Set SubFolder
    Set SubFolder = Application.Session.PickFolder

'   // Loop through the Items in the folder backwards
    For lngCount = Items.Count To 1 Step -1
        Set Item = Items(lngCount)

        Debug.Print Item.Subject

        If Item.Class = olMail Then
'           // Mark As Read
            Item.UnRead = False
'           // Move Mail Item to sub Folder
            Item.Move SubFolder
            'Call the macro for that email
            '************
            'Enter the macro here
            '************
        End If
    Next lngCount

MsgErr_Exit:
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set olNs = Nothing
    Set Item = Nothing

    Exit Sub

'// Error information
MsgErr:
    MsgBox "An unexpected Error has occurred." _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume MsgErr_Exit
End Sub

---

Чтобы переместить выбранную электронную почту в папку «Входящие», попробуйте следующее

Option Explicit
Public Sub Exampls()
    Dim olNs As Outlook.NameSpace
    Set olNs = Application.GetNamespace("MAPI")

    Dim Inbox  As Outlook.MAPIFolder
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)

    Dim Item As Object
    Set Item = ActiveExplorer.selection(1)

    Debug.Print Item.Parent

    If TypeOf Item Is Outlook.MailItem Then

        If Not Item.Parent = Inbox Then
           Item.Move Inbox
           MsgBox "Item Subject: " & Item.Subject & " Has Been Move to " & Inbox.Name
        Else
            MsgBox "Item already in " & Item.Parent
            Exit Sub
        End If

    Else
        MsgBox "Selection is not MailItem"
    End If

End Sub