Como mover automaticamente as reuniões recebidas para uma pasta específica no Outlook?

Normalmente, após o envio de e-mails ou convites para reuniões, ambos são guardados na pasta Itens Enviados, tornando-a rapidamente desorganizada e difícil de gerir. Neste artigo, apresento um método para mover automaticamente os convites de reunião enviados para outra pasta assim que forem enviados.

Mover automaticamente as reuniões enviadas para uma pasta específica com código VBA

---

Mover automaticamente as reuniões enviadas para uma pasta específica com código VBA

Para mover automaticamente todos os convites de reunião enviados para outra pasta, utilize o código seguinte. Siga estes passos:

1. Prima e mantenha premidas as teclas ALT + F11 para abrir a janela do Microsoft Visual Basic for Applications.

2. Na janela do Microsoft Visual Basic for Applications, faça duplo clique em ThisOutlookSession no painel Project1 (VbaProject.OTM) para abrir o módulo e, em seguida, copie e cole o código seguinte no módulo em branco.

Código VBA: Mover automaticamente as reuniões enviadas para uma pasta específica

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. De seguida, guarde e feche a janela do código. A partir de agora, sempre que um e-mail de reunião for enviado, será automaticamente movido para uma nova pasta denominada Meetings, localizada na pasta Itens Enviados. Veja a captura de ecrã: