Sub MoveProject()
Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem
Dim strProject As String
Dim Proceed As VbMsgBoxResult
Set objNS = Application.GetNamespace("MAPI")
Dim appOutlook As New Outlook.Application
Set nms = appOutlook.GetNamespace("MAPI")

strProject = InputBox("Please enter Project")

strFolder = nms.Session.GetDefaultFolder(olPublicFoldersAllPublicFolders).Parent
' 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 fld = nms.Folders(strFolder).Folders("All Public Folders").Folders("Projects").Folders(strProject)
    
For intX = 1 To objNS.Folders.Count
If objNS.Folders.Item(intX).Name = "Public Folders" Then

Exit For
End If
Next

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

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is Selected
Exit Sub
End If

Set oSelection = Application.ActiveExplorer.Selection

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 " & strProject & "?", _
    vbYesNo + vbQuestion, "Confirm Move")
    If Proceed = vbYes Then
Set objEmail = objX
objEmail.Move fld
    End If
End If
Next


Set objItem = Nothing
Set objFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
End Sub