Smart Archive for Outlook

SmartArchive.vba

' Smart Archive - moves all of the selected emails to the archive folder appropriate for that email instead of
' just moving them to the default email account's archive folder.
' Note that you'll need to change the hardcoded email addresses & Archive folder names.
Sub MoveSelectedToArchives()
    
    Dim myOlApp As New Outlook.Application
    Set sel = myOlApp.ActiveExplorer.Selection
    Dim mi As mailItem
    Set mi = myOlApp.ActiveExplorer.Selection.item(1)
       


    Dim archFolder As folder
    Dim em As String
    For Each item In myOlApp.ActiveExplorer.Selection
        ' Get the account of the current mail item
        em = SelectedEmail(item)
    
        ' Hardcoded map or switch of the archive folder for each account
        Set archFolder = EmailToArchive(em)
        
        'MsgBox em & " -> " & archFolder.Name
        
        ' Move current item to the right archive folder
        item.Move archFolder

    Next

    
End Sub

' Given an email account, what is the archive folder name       
Function EmailToArchive(email As String) As MAPIFolder

    Dim olApp As New Outlook.Application
    Dim olNameSpace As Outlook.NameSpace
    Set olNameSpace = olApp.GetNamespace("MAPI")
    
    email = LCase(email)
    Dim archiveName As String
    ' TODO change these to your email addresses & Archive folders
    Select Case email
        Case "[email protected]"
            archiveName = "Archive"
        Case "[email protected]"
            archiveName = "MyArchive"
        Case "[email protected]"
            archiveName = "Archive"
    End Select
    
    Dim f As MAPIFolder
    Set f = olNameSpace.Folders(email)
    Dim a As MAPIFolder
    Set a = f.Folders(archiveName)
    
    Set EmailToArchive = a
End Function

' What is the email account address of the given email message
Function SelectedEmail(mi) As String

    Dim strPattern As String: strPattern = "^(\\\\)?([a-zA-Z0-9_\.-]+@[a-zA-Z0-9_\.-]+)(.*)?$"
    Dim regEx As New RegExp
    Set regEx = CreateObject("VBScript.RegExp")
    With regEx
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = strPattern
    End With
    
    Dim folder As MAPIFolder
    Set folder = mi.parent

    Set myMatches = regEx.Execute(folder.FullFolderPath)
    'TODO assert there's only one
    For Each m In myMatches
        SelectedEmail = m.SubMatches(1)
    Next
    
End Function


'https://www.getmailbird.com/setup-unified-inbox-outlook/
Sub UnifiedInbox()
    Dim myOlApp As New Outlook.Application
    txtSearch = "folder:Inbox"
    ' Could also use scope of olSearchScopeAllOutlookItems
    myOlApp.ActiveExplorer.Search txtSearch, olSearchScopeAllFolders
    
    Set myOlApp = Nothing
End Sub