Move selected email to folder based on InputBox value

Question

I want to move emails based on value in InputBox.

Idea is, I select one or more emails and run script.

• InputBox appears and I fill in 6 digits representing a folder name.
• If the folder exists anywhere in Outlook inbox move the selected emails to this folder.
• If the folder doesn't exist, then MsgBox (No such folder).
• If the folder exists more then once, then MsgBox (Multiple records).

Answer 1

Sub MoveEmailsToTicketFolder()
Dim objSelection As Selection
Dim objMail As MailItem
Dim strTicketNumber As String
Dim strFolderName As String
Dim objNS As NameSpace
Dim objDestFolder As Folder

' Get the current selection
Set objSelection = Application.ActiveExplorer.Selection

' Check if at least one email is selected
If objSelection.Count = 0 Then
    MsgBox "Please select at least one email to move.", vbExclamation
    Exit Sub
End If

' Ask user for the ticket number
strTicketNumber = InputBox("Enter the ticket number to move the emails to:", "Move Emails")

' Ensure the user entered a ticket number
If strTicketNumber = "" Then
    MsgBox "No ticket number specified. Operation canceled.", vbExclamation
    Exit Sub
End If

' Create the full folder name by adding the prefix
strFolderName = "TICKET/" & strTicketNumber

' Get the namespace (MAPI)
Set objNS = Application.GetNamespace("MAPI")

' Search for the destination folder including subfolders
Set objDestFolder = GetFolderByName(objNS.Folders.Item(1), strFolderName)

If objDestFolder Is Nothing Then
    MsgBox "Folder not found: " & strFolderName, vbExclamation
    Exit Sub
End If

' Move each selected email to the folder
Dim objItem As Object
For Each objItem In objSelection
    If TypeName(objItem) = "MailItem" Then
        objItem.Move objDestFolder
    End If
Next objItem

MsgBox "Emails moved to folder: " & strFolderName

End Sub

Function GetFolderByName(ByVal ParentFolder As Folder, ByVal FolderName As String) As Folder Dim SubFolder As Folder Dim FoundFolder As Folder

' Check if the current folder matches the name
If ParentFolder.Name = FolderName Then
    Set GetFolderByName = ParentFolder
    Exit Function
End If

' Search in subfolders
For Each SubFolder In ParentFolder.Folders
    Set FoundFolder = GetFolderByName(SubFolder, FolderName)
    If Not FoundFolder Is Nothing Then
        Set GetFolderByName = FoundFolder
        Exit Function
    End If
Next SubFolder

' If not found, return Nothing
Set GetFolderByName = Nothing

End Function