kiến thức [Outlook VBA] Tự động chuyển mail mới nhận vào thư mục mang tên người gửi

Option Explicit
Private WithEvents objItems As Outlook.Items

Private Sub Class_Initialize()
    Dim objInboxFld As Outlook.Folder
    Set objInboxFld = Application.Session.DefaultStore.GetDefaultFolder(olFolderInbox)
    Set objItems = objInboxFld.Items
End Sub

Private Sub objItems_ItemAdd(ByVal Item As Object)
    Call MoveToSendersFolder(Item)
End Sub

Private Sub MoveToSendersFolder(objItem As Outlook.MailItem)
    Dim objNewFld As Outlook.Folder
    Dim objStore As Outlook.Store
    Dim objNS As Outlook.NameSpace
    Dim objSync As Outlook.SyncObject
    Dim objInboxFld As Outlook.Folder
    Dim objRootFld As Outlook.Folder
    Dim objInsp As Outlook.Inspector
    If TypeOf objItem Is Outlook.MailItem Then
        Set objNS = Application.Session
        Set objStore = objNS.DefaultStore
        Set objRootFld = objStore.GetRootFolder
        If FolderExistsInSenders(objItem.SenderEmailAddress) Then
            Set objNewFld = objRootFld.Folders("Senders").Folders(objItem.SenderEmailAddress)
            objItem.Move objNewFld
        Else
            Set objNewFld = objRootFld.Folders("Senders").Folders.Add(objItem.SenderEmailAddress)
            objItem.Move objNewFld
        End If
        If Err.Number = 0 Then
            Set objSync = objNS.SyncObjects.AppFolders
            objRootFld.InAppFolderSyncObject = True
            objSync.Start
            Set objInsp = objItem.GetInspector
            objItem.Display
            objInsp.WindowState = olNormalWindow
        End If
    End If
    Set objNS = Nothing
    Set objRootFld = Nothing
    Set objNewFld = Nothing
    Set objStore = Nothing
    Set objInboxFld = Nothing
    Set objSync = Nothing
    Set objInsp = Nothing
End Sub

Private Function FolderExistsInSenders(FolderName As String) As Boolean
    Dim FolderObject As Folder
    Dim SendersFldr As Folder
    On Error GoTo FolderNotFoundErr
    Set SendersFldr = Application.Session.DefaultStore.GetRootFolder.Folders("Senders")
    If SendersFldr.Folders.Count = 0 Then
        FolderExistsInSenders = False
        Exit Function
    End If
    For Each FolderObject In SendersFldr.Folders
        If FolderObject.Name = FolderName Then
            FolderExistsInSenders = True
            Exit For
        Else: FolderExistsInSenders = False
        End If
    Next
    If Err.Number = -2147221233 Then
FolderNotFoundErr: MsgBox "You need to create a folder named 'Senders' before running this macro. Please try again.", vbExclamation, "Senders Folder Not Found"
    End If
    Set FolderObject = Nothing
    Set SendersFldr = Nothing
End Function

Option Explicit
Private MoveToSendersFolder As cls_MoveNewMails
Private Sub Application_Startup()
    Set MoveToSendersFolder = New cls_MoveNewMails
End Sub