Как автоматично да преместите изпратени срещи в определена папка в Outlook?

Автор: Xiaoyang Последна промяна: 2018-11-29

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

Автоматично преместване на изпратените срещи в определена папка с 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