Outlook Macro to move mails in the same folders as previous

SmartMove.vbs

Sub SmartArchive()
    Dim objApp As Outlook.Application
    Dim objSelection As Outlook.Selection
    Dim objMail As Outlook.MailItem
    Dim objConversation As Outlook.Conversation
    Dim objRootItems As Outlook.SimpleItems
    Dim objChildItems As Outlook.SimpleItems
    Dim objRootItem As Object
    Dim objChildItem As Object
    Dim objFolder As Outlook.folder
    Dim objTargetFolder As Outlook.folder
    Dim strPrompt As String
    Dim blnMove As Boolean
    Dim i As Integer
    Dim blnSameThread As Boolean
    Dim strConversationID As String
    
    Set objApp = Outlook.Application
    Set objSelection = objApp.ActiveExplorer.Selection
    
    If objSelection.Count = 0 Then
        MsgBox "No items selected.", vbExclamation
        Exit Sub
    End If
    
    Set objMail = objSelection.Item(1)
    
    If objMail.Class <> olMail Then
        MsgBox "Please select mail items.", vbExclamation
        Exit Sub
    End If
    
    Set objConversation = objMail.GetConversation
    
    If objConversation Is Nothing Then
        MsgBox "No conversation found for the selected email.", vbExclamation
        Exit Sub
    End If
    
    strConversationID = objConversation.ConversationID
    blnSameThread = True
    
    ' Check if all selected mails are in the same conversation
    For i = 1 To objSelection.Count
        Set objMail = objSelection.Item(i)
        If objMail.GetConversation.ConversationID <> strConversationID Then
            blnSameThread = False
            Exit For
        End If
    Next i
    
    If Not blnSameThread Then
        MsgBox "Selected emails are not in the same conversation.", vbExclamation
        Exit Sub
    End If
    
    Set objRootItems = objConversation.GetRootItems
    
    ' Iterate through all root items in the conversation
    For Each objRootItem In objRootItems
        If objRootItem.Class = olMail Then
            Set objMail = objRootItem
            Set objFolder = objMail.parent
            
            ' Ensure the folder is not Inbox, Sent Items, Calendar, or a calendar folder
            If objFolder.DefaultItemType = olMailItem And objFolder.Name <> "Inbox" And objFolder.Name <> "Sent Items" And objFolder.Name <> "Calendar" Then
                Set objTargetFolder = objFolder
                Exit For
            End If
        End If
    Next objRootItem
    
    ' If no target folder found, check child items in the conversation
    If objTargetFolder Is Nothing Then
        For Each objRootItem In objRootItems
            Set objChildItems = objConversation.GetChildren(objRootItem)
            For Each objChildItem In objChildItems
                If objChildItem.Class = olMail Then
                    Set objMail = objChildItem
                    Set objFolder = objMail.parent
                    
                    ' Ensure the folder is not Inbox, Sent Items, Calendar, or a calendar folder
                    If objFolder.DefaultItemType = olMailItem And objFolder.Name <> "Inbox" And objFolder.Name <> "Sent Items" And objFolder.Name <> "Calendar" Then
                        Set objTargetFolder = objFolder
                        Exit For
                    End If
                End If
            Next objChildItem
            If Not objTargetFolder Is Nothing Then Exit For
        Next objRootItem
    End If
    
    If objTargetFolder Is Nothing Then
        MsgBox "No suitable folder found in the conversation.", vbExclamation
        Exit Sub
    End If
    
    strPrompt = "Do you want to move the selected emails to the folder:" & vbNewLine & objTargetFolder.Name & "?"
    blnMove = MsgBox(strPrompt, vbYesNo + vbQuestion, "Move Emails") = vbYes
    
    If blnMove Then
        For i = 1 To objSelection.Count
            Set objMail = objSelection.Item(i)
            objMail.UnRead = False ' Mark as read
            objMail.Move objTargetFolder
        Next i
    End If
End Sub