Option Explicit

Sub MoveProject()

Dim objNS As Outlook.Namespace
Dim projectParentFolder As Outlook.MAPIFolder
Dim objFolder As Outlook.MAPIFolder
Dim objX As Object

Dim strProject As String
Dim Proceed As VbMsgBoxResult
Dim strFolder As String
Dim intX As Long

If Application.ActiveExplorer.Selection.count = 0 Then
    'Require that this procedure be called only when a message is Selected
    MsgBox "Select at least one mailitem", , "MoveProject"
    Exit Sub
End If

strProject = InputBox("Please enter Project")

strProject = Trim(strProject)

If Len(strProject) > 4 Then strProject = Left(strProject, 4)

Set objNS = Application.GetNamespace("MAPI")

' If the public folder location is not \\public folders\all public folders\projects\001 etc
' then the below line is required to be changed
Set projectParentFolder = objNS.Session.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("Projects")

For intX = 1 To projectParentFolder.Folders.count
    If Left(projectParentFolder.Folders.item(intX).name, Len(strProject)) = strProject Then
        Set objFolder = projectParentFolder.Folders.item(intX)
        Exit For
    End If
Next

If objFolder Is Nothing Then
    MsgBox "This folder doesn't exist!", vbOKOnly
    GoTo exitRoutine
End If

For intX = ActiveExplorer.Selection.count To 1 Step -1
    Set objX = ActiveExplorer.Selection.item(intX)
    If objX.Class = olMail Then
        Proceed = MsgBox("Are you sure you want move the message to the Projects Folder " & objFolder & "?", _
            vbYesNo + vbQuestion, "Confirm Move")
        If Proceed = vbYes Then
            objX.Move objFolder
        End If
    End If
Next

exitRoutine:
    Set objX = Nothing
    Set objFolder = Nothing
    Set projectParentFolder = Nothing
    Set objNS = Nothing

End Sub