Public WithEvents myItem As MailItem 'for trapping deletion of opened mail Public WithEvents myInspector As Inspectors 'for trapping new windows Public WithEvents myExplorer As Explorer 'for folder reference Public WithEvents myFolder As Folder 'for trapping mail deletion in main outlook window Public myNameSpace As NameSpace 'Parent folder Private Sub Application_Startup() Set myInspector = Application.Inspectors Set myExplorer = Application.ActiveExplorer Set myFolder = myExplorer.CurrentFolder Set myNameSpace = Application.GetNamespace("MAPI") End Sub Private Sub myExplorer_BeforeFolderSwitch(ByVal NewFolder As Object, Cancel As Boolean) Set myFolder = NewFolder End Sub Private Sub myFolder_BeforeItemMove(ByVal item As Object, ByVal MoveTo As MAPIFolder, Cancel As Boolean) If TypeName(item) = "MailItem" Then 'only trap mail items Dim lMI As MailItem Set lMI = item If MoveTo Is Nothing And lMI.Parent <> "Deleted Items" Then 'Item was deleted moveIMAPItem lMI Cancel = True 'bypass normal deletion function End If End If End Sub Private Sub myInspector_NewInspector(ByVal Inspector As Inspector) If Inspector.CurrentItem.Class = olMail Then Set myItem = Inspector.CurrentItem 'New window for reading mail End Sub Private Sub myItem_BeforeDelete(ByVal item As Object, Cancel As Boolean) If TypeName(myItem) = "MailItem" Then 'only trap mail items moveIMAPItem item Cancel = True 'bypass normal deletion End If End Sub Private Sub moveIMAPItem(ByVal item As Object) Dim lMI As MailItem Dim fParent As Folder Dim parentFolder As Folder Dim trashFolder As Folder Set lMI = item Set fParent = myExplorer.CurrentFolder Do Until fParent.Parent = myNameSpace 'Root folder Set fParent = fParent.Parent Loop Set parentFolder = fParent If parentFolder.Folders("Deleted Items") Is Nothing Then 'Deleted Items folder doesn't exist MsgBox "Unable to find folder named 'Deleted Items'", vbOKOnly + vbInformation, "IMAP Delete" 'Inform user and exit routine Exit Sub End If Set trashFolder = parentFolder.Folders("Deleted Items") 'Set destination lMI.Move trashFolder 'move email End Sub