Как автоматически перемещать удалённые элементы разных типов в отдельные папки в Outlook?

В Outlook все виды Удаленные элементы (письма, задачи, контакты и т.д.) перемещаются в папку Удаленные элементы. Если вы хотите перемещать элементы в разные папки в зависимости от их типа в папке Удаленные элементы, как показано на снимке экрана ниже, как это можно реализовать в Outlook?

---

Автоматическое перемещение разных типов Удаленные элементы в разные папки с помощью кода VBA

Приведённый ниже код VBA автоматически перемещает удалённые элементы в разные папки. Выполните следующие действия:

1. Запустите Outlook и удерживайте клавиши ALT + F11, чтобы открыть окно Microsoft Visual Basic для приложений.

2. Затем дважды щёлкните элемент ThisOutlookSession в области Project-Project1 и вставьте приведённый ниже код в пустое окно редактора:

Код VBA: автоматическое перемещение разных типов Удаленные элементы в разные папки

Public WithEvents GDeletedFolder As Outlook.Folder
Public WithEvents GDeletedItems As Outlook.Items
Private Sub Application_Startup()
  Set GDeletedFolder = Application.Session.GetDefaultFolder(olFolderDeletedItems)
  Set GDeletedItems = GDeletedFolder.Items
End Sub
Private Sub GDeletedItems_ItemAdd(ByVal Item As Object)
'Updateby ExtendOffice
Dim xTargetFolder As Outlook.Folder
On Error Resume Next
Select Case TypeName(Item)
  Case "MailItem", "PostItem", "ReportItem", "MeetingItem"
    Set xTargetFolder = GDeletedFolder.Folders("Deleted Mails")
    If xTargetFolder Is Nothing Then
      Set xTargetFolder = GDeletedFolder.Folders.Add("Deleted Mails", olFolderInbox)
    End If
  Case "AppointmentItem"
    Set xTargetFolder = GDeletedFolder.Folders("Deleted Appointments")
    If xTargetFolder Is Nothing Then
      Set xTargetFolder = GDeletedFolder.Folders.Add("Deleted Appointments", olFolderCalendar)
    End If
  Case "ContactItem", "DistListItem"
    Set xTargetFolder = GDeletedFolder.Folders("Deleted Contacts")
    If xTargetFolder Is Nothing Then
      Set xTargetFolder = GDeletedFolder.Folders.Add("Deleted Contacts", olFolderContacts)
    End If
  Case "TaskItem"
    Set xTargetFolder = GDeletedFolder.Folders("Deleted Tasks")
    If xTargetFolder Is Nothing Then
      Set xTargetFolder = GDeletedFolder.Folders.Add("Deleted Tasks", olFolderTasks)
    End If
  Case "JournalItem"
    Set xTargetFolder = GDeletedFolder.Folders("Deleted Journals")
    If xTargetFolder Is Nothing Then
      Set xTargetFolder = GDeletedFolder.Folders.Add("Deleted Journals", olFolderJournal)
    End If
  Case "NoteItem"
    Set xTargetFolder = GDeletedFolder.Folders("Deleted Notess")
    If xTargetFolder Is Nothing Then
      Set xTargetFolder = GDeletedFolder.Folders.Add("Deleted Notess", olFolderNotes)
    End If
End Select
If xTargetFolder Is Nothing Then Exit Sub
Item.Move xTargetFolder
Set xTargetFolder = Nothing
End Sub

3. Сохраните этот код и перезапустите Outlook, чтобы активировать его.

4. Теперь при удалении элемента он будет автоматически перемещаться в соответствующую папку нужного типа внутри папки Удаленные элементы.

5. Чтобы просмотреть результат, нажмите значок в нижней части области папок, а затем выберите Папки, чтобы отобразить «Развернуть все папки» в области. См. снимки экрана: