Как переместить каждую электронную почту из папки «Входящие» в подпапку

Question

Кажется, у меня возникают проблемы с перемещением электронных писем из папки «Входящие» в подпапку «Входящие». Я всегда думал, что мой код работает до сегодняшнего дня. Я заметил, что это всего лишь половина писем. Мне не нужен код «переместить весь», у меня есть цель для этого, но мне просто нужно переместить все электронные письма, а не все сразу (мне нужно было проверить каждый адрес электронной почты). Пожалуйста, взгляните на мой код ниже. myNamespace.Folders.Item(1).Folders.Item(2) - моя основная папка.

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

here is good link

Moves Перспективы почтовых отправлений в Суб папку по адресу электронной почты

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_One@email.com" 
'     // Set SubFolder of Inbox 
        Set SubFolder = Inbox.Folders("Folder One") 
        Set Item = Items.Find("[SenderEmailAddress] = 'Email_One@email.com'") 
        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_Two@email.com" 
'     // Set SubFolder of Inbox 
        Set SubFolder = Inbox.Folders("Folder Two") 
        Set Item = Items.Find("[SenderEmailAddress] = 'Email_Two@email.com'") 
        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 

Или переместить все элементы почты Входящие в подпапке

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