Как автоматически переместить отправленные встречи в определенную папку в Outlook?

Author Xiaoyang Last modified 2025-08-26

Обычно после отправки писем или встреч, они оба оказываются в папке Отправленные. Таким образом, папка Отправленные может стать довольно беспорядочной и громоздкой. В этой статье я представлю метод автоматического перемещения отправленных встреч в другую папку сразу после отправки встречи.

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

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

Чтобы автоматически переместить все отправленные приглашения на встречу в другую папку, следующий код может вам помочь, выполните следующие действия:

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

2. В окне Microsoft Visual Basic для приложений дважды щелкните ThisOutlookSession в области Project1(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

3. Затем сохраните и закройте окно кода. Теперь, когда письмо с встречей отправляется, оно будет автоматически перемещено в новую папку под названием Meetings внутри папки Отправленные, см. скриншот: