Sub MakeNewPIFolderAndMoveEmail()
    Dim objOutlook As Outlook.Application
    Dim myItems As Outlook.Items
    Dim fldRoot As Outlook.MAPIFolder
    Dim fldPIs As Outlook.MAPIFolder, fldNew As Outlook.MAPIFolder
    Dim strFolderName As String
    Dim Explorer
    Dim CurrentItem
        
    Set objOutlook = CreateObject("outlook.application")

    ' from the default inbox to the parent which is your mailbox
    Set fldRoot = objOutlook.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent
    ' from the mailbox to a folder at the same level as the Inbox
    Set fldPIs = fldRoot.Folders("PIs")

    strFolderName = InputBox("Enter name for the PI folder", "Folder Name")
    
    If Len(strFolderName) = 0 Then
      Exit Sub
    End If
    
    Set fldNew = fldPIs.Folders.Add(strFolderName)
    Set Explorer = Application.ActiveExplorer
 
    ' Check whether any item is selected in the current folder.
    If Explorer.Selection.Count Then
 
      ' Get the first selected item.
      Set CurrentItem = Explorer.Selection(1)
      If CurrentItem.Class = olMail Then
        CurrentItem.Move fldNew
      End If
    End If
End Sub