I am trying to modify code from How to move each emails from inbox to a sub-folder posted by 0m3r.
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
This code works with an Outlook profile that has one email account.
In my case, MS Outlook I use has two email accounts. I need to collect emails from the second account (planner@gmail.com), which is not default.
I modified the line:
Set olNs = Application.GetNamespace("MAPI")
To:
Set olNs = Application.GetNamespace("MAPI").Folders("planner@gmail.com")
I get an error message
An unexpected Error has occurred. Error number: 13. Error Description: Type mismatch
I use MS Outlook 2016 (x64).