Move attachments that are emails to a subfolder in Outlook

Question

Email is received once a day from abc@xyz.com with subject line being "emails" with attachments that are emails (up to 20 attachments at 15kb each).

I am trying to move those attachments to a sub folder named "Extra" within my Outlook inbox.

I'm having trouble modifying my old code. I'm thinking its coming from here. Const attPath As String = "Mailbox/Extra".

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)

    On Error GoTo ErrorHandler

    'Only act if it's a MailItem
    Dim Msg As Outlook.MailItem
    If TypeName(item) = "MailItem" Then
        Set Msg = item

        'From specified user with specified subject
        If (Msg.SenderName = "teresa") And _
          (Msg.Subject = "emails") And _
          (Msg.Attachments.Count >= 1) Then

            'Set folder to save in.
            Dim olDestFldr As Outlook.MAPIFolder
            Dim myAttachments As Outlook.Attachments
            Dim Att As String

            'location to save in. 
            Const attPath As String = "Mailbox/Extra"

            ' save attachment
            Set myAttachments = item.Attachments
            Att = myAttachments.item(1).DisplayName
            myAttachments.item(1).SaveAsFile attPath & Att

            ' mark as read
            Msg.UnRead = False
        End If
    End If

ProgramExit:
    Exit Sub

ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit

End Sub

Answer 1

It appears you can't move attachments to another folder in Outlook without saving them locally beforehand.

The following code should hopefully work for you...

In ThisOutlookSession:

Private WithEvents InboxItems As Outlook.Items

Private Sub Application_Startup()
    On Error Resume Next
    Set InboxItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub InboxItems_ItemAdd(ByVal Item As Object)
    On Error Resume Next
    If TypeName(Item) = "MailItem" Then Call MoveAttachments(Item)
End Sub

In a module:

Function MoveAttachments(ByVal Item As Object)
    
    Const AttachmentFolder As String = "Extra"
    
    Dim ThisNameSpace As Outlook.NameSpace: Set ThisNameSpace = Application.GetNamespace("MAPI")
    Dim Inbox As Outlook.MAPIFolder: Set Inbox = ThisNameSpace.GetDefaultFolder(olFolderInbox)
    
    On Error Resume Next
        Dim AttFolder As Outlook.Folder: Set AttFolder = Inbox.Folders(AttachmentFolder)
        If AttFolder Is Nothing Then Set AttFolder = Inbox.Parent.Folders(AttachmentFolder)
        If AttFolder Is Nothing Then Exit Function
    On Error GoTo ExitSub
    
    With Item   'From specified user with specified subject
        If .SenderName = "teresa" And .Subject = "emails" And .Attachments.Count >= 1 Then
            Call MoveAttachedMessages(Item, AttFolder, False)
        End If
    End With
        
ExitSub:
End Function

Function MoveAttachedMessages(ByVal Item As Object, _
    AttachmentFolder As Outlook.Folder, _
    Optional DeleteMoved As Boolean)

    If IsMissing(DeleteMoved) Then DeleteMoved = False

    Dim TempPath As String: TempPath = Environ("temp") & "\OLAtt-" & Format(Now(), "yyyy-mm-dd") & "\"
    If Dir(TempPath, vbDirectory) = "" Then MkDir TempPath

    Dim ThisNameSpace As Outlook.NameSpace: Set ThisNameSpace = Application.GetNamespace("MAPI")
    Dim AttItems As Outlook.Attachments, AttItem As Outlook.Attachment
    Dim msgItem As Outlook.MailItem

    ' Save attachments
    On Error Resume Next

    Set AttItems = Item.Attachments
    For Each AttItem In AttItems
        If LCase(Right(AttItem.FileName, 4)) = ".msg" Then
            AttItem.SaveAsFile TempPath & AttItem.FileName
            Set msgItem = ThisNameSpace.OpenSharedItem(TempPath & AttItem.FileName)
            'Set msgItem = Outlook.CreateItemFromTemplate(TempPath & AttItem.FileName)
            If Not msgItem Is Nothing Then
                msgItem.UnRead = True
                msgItem.Save
                msgItem.Move AttachmentFolder
                If msgItem.Saved = True And DeleteMoved = True Then
                    AttItem.Delete
                    Item.Save
                End If
            End If
        End If
    Next AttItem

    If Err.Number = 0 Then Item.UnRead = False ' Mark as Read

    If Dir(TempPath, vbDirectory) <> "" Then
        Kill TempPath & "\" & "*.*"
        RmDir TempPath
    End If
    
End Function

Note: not sure why, but using this code the copied attachments can't be marked as unread. I've left in the code, maybe someone else can identify the issue.

Thanks to Seby for identifying the issue; code has been updated

Answer 2

This is my code with my Folders

-Inbox
--Folder1
---SubFolder1
---SubFolder2
--Folder2

.. Serch email with Attachement in Folder1 and move in specific SubFolder

Sub MoveAttachmentToFolder(Item As Outlook.MailItem)

'Dichiarazione
Dim OutApp As Outlook.Application
Dim Namespace As Outlook.Namespace
Dim Mfolder As Outlook.MAPIFolder
Dim Folder As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim UserFolder As Outlook.MAPIFolder
Dim UserUserFolder As Outlook.MAPIFolder
Dim olkAtt As Outlook.Attachment

Set OutApp = New Outlook.Application
Set Namespace = OutApp.GetNamespace("MAPI")
Set Root = Namespace.Folders("root")
Set Folder = Root.Folders("Inbox")
Set SubFolder = Folder.Folders("Folder1")
Set UserFolder = SubFolder.Folders("SubFolder1")
Debug.Print UserFolder.Name

    'Check each attachment
    For Each olkAtt In Item.Attachments
        'If the attachment's file name with 202627
         If InStr(LCase(olkAtt), "202627") > 0 Then
            'Move the message to SubFolder "DL IT CG SKY-DE PRJ"
            Item.Move SubFolder.Folders("SubFolder1")
            'No need to check any of this message's remaining attachments
            Exit For
        End If
    Next
    Set olkAtt = Nothing
End Sub