Як автоматично перемістити надіслані наради до певної папки в Outlook?

Зазвичай після надсилання електронних листів або нарад обидва вони будуть розміщені в папці Надіслані. Отже, папка Надіслані предмети буде значно брудною та громіздкою. У цій статті я познайомлюсь із методом автоматичного переміщення надісланих нарад в іншу папку після розсилання наради.

Автоматично переміщувати надіслані наради до певної папки з кодом VBA

Автоматично переміщувати надіслані наради до певної папки з кодом VBA

Щоб автоматично перенести всі надіслані запрошення на нараду в іншу папку, вам може допомогти наступний код, зробіть так:

1. Утримуйте клавішу ALT + F11 ключі, щоб відкрити Microsoft Visual Basic для додатків вікна.

2, в Microsoft Visual Basic для додатків вікно, двічі клацніть ThisOutlookSession від Проект1 (VbaProject.OTM) , щоб відкрити режим, а потім скопіюйте та вставте наступний код у порожній модуль.

Код VBA: Автоматично переміщувати надіслані наради до певної папки

Private WithEvents GExplorer As Outlook.Explorer
Public WithEvents GSentFolder As Outlook.Folder
Public WithEvents GSentItems As Outlook.Items
Private Sub Application_Startup()
    Set GExplorer = Outlook.Application.ActiveExplorer
End Sub
Private Sub GExplorer_SelectionChange()
Dim xFolder As Folder, xRootFolder As Folder
Dim xRootFldName As String
Dim xPos As Integer
    On Error Resume Next
    Set xFolder = Outlook.Application.ActiveExplorer.CurrentFolder
    xPos = VBA.InStr(3, xFolder.FolderPath, "\")
    If xPos > 0 Then
        xRootFldName = VBA.Mid(xFolder.FolderPath, 3, xPos - 3)
    Else
        xRootFldName = VBA.Mid(xFolder.FolderPath, 3, Len(xFolder.FolderPath) - 2)
    End If
    Set xRootFolder = Outlook.Application.Session.Folders(xRootFldName)
    Set GSentFolder = xRootFolder.Folders("Sent Items")
    Set GSentItems = GSentFolder.Items
End Sub
Private Sub GSentItems_ItemAdd(ByVal Item As Object)
    Dim xMeetingItem As Outlook.MeetingItem
    Dim xTargetFolder As Outlook.Folder
    On Error Resume Next
    If Item.Class <> olMeetingRequest Then Exit Sub
    Set xMeetingItem = Item
    Set xTargetFolder = GSentFolder.Folders("Meetings")
    If xTargetFolder Is Nothing Then
        Set xTargetFolder = GSentFolder.Folders.Add("Meetings")
    End If
    xMeetingItem.Move xTargetFolder
End Sub

переміщення документа надіслано засідання 1

3. Потім збережіть і закрийте вікно коду. Тепер, коли електронне повідомлення про зустріч буде розіслано, воно буде переміщено до нової папки з іменем засідання під Відправлені папку автоматично, див. знімок екрана:

переміщення документа надіслано засідання 2