Jak automaticky přesouvat odeslané schůzky do konkrétní složky v Outlooku?

Autor: Xiaoyang Naposledy změněno: 2018-11-29

Obvykle budou po odeslání e-mailů nebo schůzek oba umístěny do složky Odeslaná pošta. Složka Odeslané položky bude tedy značně špinavá a těžkopádná. V tomto článku představím metodu automatického přesunu odeslaných schůzek do jiné složky po odeslání schůzky.

Automaticky přesuňte odeslané schůzky do konkrétní složky pomocí kódu VBA

Automaticky přesuňte odeslané schůzky do konkrétní složky pomocí kódu VBA

Chcete-li automaticky přesunout všechny odeslané pozvánky na schůzku do jiné složky, může vám pomoci následující kód, postupujte takto:

1. Podržte ALT + F11 klávesy pro otevření Microsoft Visual Basic pro aplikace okno.

2. V Microsoft Visual Basic pro aplikace okno, dvakrát klikněte ThisOutlookSession z Project1 (VbaProject.OTM) v podokně otevřete režim a poté zkopírujte a vložte následující kód do prázdného modulu.

Kód VBA: Automaticky přesunout odeslané schůzky do konkrétní složky

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

dokument přesun poslán schůzku 1

3. Poté uložte a zavřete okno kódu. Nyní, když je e-mail schůzky odeslán, bude přesunut do nové složky s názvem setkání pod Odeslané položky složka automaticky, viz screenshot:

dokument přesun poslán schůzku 2