vba - Cómo mover cada correo electrónico desde la bandeja de entrada a una subcarpeta

email outlook

Question

Esta pregunta ya tiene una respuesta aquí:

• Para cada ciclo: algunos elementos se omiten al recorrer el buzón de Outlook para eliminar elementos 2 respuestas

Parece que tengo problemas para mover correos electrónicos de la bandeja de entrada a una subcarpeta de la bandeja de entrada. Siempre pensé que mi código funcionaba hasta hoy. Noté que solo mueve la mitad de los correos electrónicos. No necesito un código de "mover todo", tengo un propósito para esto, pero solo necesito mover cada correo electrónico y no todos a la vez (necesitaba revisar cada correo electrónico). Por favor, eche un vistazo a mi código a continuación. myNamespace.Folders.Item(1).Folders.Item(2) es mi bandeja de entrada principal.

Sub MoveEachInboxItems()
Dim myNamespace As Outlook.NameSpace
Set myNamespace = Application.GetNamespace("MAPI")
For Each Item In myNamespace.Folders.Item(1).Folders.Item(2).Items
Dim oMail As Outlook.MailItem: Set oMail = Item
Item.UnRead = True
Item.move myNamespace.Folders.Item(1).Folders.Item(2).Folders("Other Emails")
Next
End Sub

Answer 1

aquí hay buen enlace

Mueve los elementos de correo de Outlook a una subcarpeta por dirección de correo electrónico

Option Explicit
Public Sub Move_Items()
'' // Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim olNs As Outlook.NameSpace
Dim Item As Object
Dim Items As Outlook.Items
Dim lngCount As Long
On Error GoTo MsgErr
'' Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
'' // Loop through the Items in the folder backwards
For lngCount = Items.Count To 1 Step -1
Set Item = Items(lngCount)
If Item.Class = olMail Then
Select Case Item.SenderEmailAddress
'' // Email_One
Case "[email protected]"
'' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Folder One")
Set Item = Items.Find("[SenderEmailAddress] = ''[email protected]''")
If TypeName(Item) <> "Nothing" Then
'' // Mark As Read
Item.UnRead = False
'' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
'' // Email_Two
Case "[email protected]"
'' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Folder Two")
Set Item = Items.Find("[SenderEmailAddress] = ''[email protected]''")
If TypeName(Item) <> "Nothing" Then
'' // Mark As Read
Item.UnRead = False
'' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
End Select
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Set Items = 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

O para mover todos los elementos de la bandeja de entrada a la subcarpeta

Option Explicit
Public Sub Move_Items()
'' // 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 = olNs.GetDefaultFolder(olFolderInbox)
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 = Inbox.Folders("Temp")
'' // Mark As Read
Item.UnRead = False
'' // Move Mail Item to sub Folder
Item.Move SubFolder
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