Hur flyttar jag automatiskt skickade möten till en viss mapp i Outlook?

Normalt, efter att ha skickat e-postmeddelanden eller möten, kommer båda att finnas i mappen Skickade objekt. Så mappen Skickade objekt kommer att vara avsevärt rörig och besvärlig. Den här artikeln kommer jag att introducera en metod för att flytta de skickade mötena till en annan mapp automatiskt efter att mötet har skickats ut.

Flytta automatiskt de skickade mötena till en specifik mapp med VBA-kod

Flytta automatiskt de skickade mötena till en specifik mapp med VBA-kod

För att automatiskt flytta alla skickade mötesinbjudningar till en annan mapp kan följande kod hjälpa dig, gör så här:

1. Håll ner ALT + F11 nycklar för att öppna Microsoft Visual Basic för applikationer fönster.

2. I Microsoft Visual Basic för applikationer dubbelklicka ThisOutlookSession från Project1 (VbaProject.OTM) rutan för att öppna läget och sedan kopiera och klistra in följande kod i den tomma modulen.

VBA-kod: Flytta automatiskt de skickade mötena till en specifik mapp

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. Spara och stäng sedan kodfönstret. Nu, när ett mötesmail skickas ut, kommer det att flyttas till en ny mapp med namnet Möten under Skickade föremål mapp automatiskt, se skärmdump: