Outlook MailMover

MailMover.vba

Option Explicit
Dim objNS As Outlook.NameSpace

Private Sub init()
  Set objNS = GetNamespace("MAPI")
End Sub

Public Sub MoveMail()
  Dim bChk As Boolean: bChk = True
  Dim objFolder As Outlook.MAPIFolder
  Dim objInbox As Outlook.MAPIFolder
  Dim objItem As Object ' MailItem,...
  Dim xlFilePath As String: xlFilePath = "H:\Outlook\AddressList.xlsx"
  Dim xlApp As Excel.Application
  Dim xlWb As Excel.Workbook
  Dim xlWs As Excel.Worksheet
  Dim i As Long
  Dim leaveExcelOpen As Boolean
  
  On Error GoTo errOut
  
  If (bChk And ActiveExplorer.NavigationPane.CurrentModule.Class = olMailModule) Then
    Call init
  Else
    bChk = False
  End If
  
  If (bChk) Then
    Set xlApp = New Excel.Application
    Set xlWb = xlApp.Workbooks.Open(xlFilePath)
    Set xlWs = xlWb.Worksheets(1)
  End If

  If (bChk And Not xlApp Is Nothing) Then
    Dim xlCell As Excel.Range
    Dim strMailAddress As String
    Dim strFolder As String
    Dim currentItem As Object
    Dim oSelection As Object
    
    Set oSelection = ActiveExplorer.Selection
    
    For i = 1 To oSelection.Count
      Set currentItem = oSelection.Item(i)
      
      ' only move if it is archived in enterprise vault
      'If (currentItem.MessageClass = "IPM.Note.EnterpriseVault.Shortcut" Or _
        currentItem.MessageClass = "IPM.Note.EnterpriseVault.PendingArchive.ArchiveMe") Then
        strMailAddress = getMailAddress(oSelection.Item(i))
        Set xlCell = xlWs.Range("A:A").Find(What:=strMailAddress)
        
        If Not (xlCell Is Nothing) Then
          strFolder = xlCell.Offset(0, 1).Text
          Set objFolder = createFolder(strFolder)
          currentItem.UnRead = False
          Call currentItem.Move(objFolder)
        Else
          xlWs.Cells(xlWs.Range("A:A").End(xlDown).Row + 1, 1).Value = strMailAddress
          xlWs.Cells(xlWs.Range("A:A").End(xlDown).Row, 2).Select
          
          xlApp.Visible = True
          leaveExcelOpen = True
        End If
      'End If
    Next
  Else
    bChk = False
  End If

cleanOut:
  On Error Resume Next
  
  If Not leaveExcelOpen Then xlApp.Quit
Exit Sub
  
errOut:
  On Error Resume Next
  Debug.Print "Error (" & Err.Number & "): " & Err.Description
  GoTo cleanOut
End Sub

Private Function getMailAddress(objMail As MailItem)
  If objMail.SenderEmailType = "EX" Then
    getMailAddress = objMail.Sender.GetExchangeUser().PrimarySmtpAddress
  Else
    getMailAddress = objMail.SenderEmailAddress
  End If
End Function

Private Function createFolder(strFolder As String) As Outlook.MAPIFolder
  Dim currentFolder As Outlook.MAPIFolder
  Dim subFolder As String
  Dim i As Long
  
  Call init
  
  Set currentFolder = objNS.GetDefaultFolder(olFolderInbox).Parent
  
  For i = LBound(Split(strFolder, "\")) + 1 To UBound(Split(strFolder, "\"))
    subFolder = Split(strFolder, "\")(i)
    If Not SubFolderExists(currentFolder, subFolder) Then
      Set currentFolder = currentFolder.Folders.Add(subFolder)
    Else
      Set currentFolder = currentFolder.Folders(subFolder)
    End If
  Next
  
  Set createFolder = currentFolder
End Function

Private Function SubFolderExists(parentFolder As Outlook.MAPIFolder, testFolder As String) As Boolean
  On Error GoTo errOut
  If Not parentFolder.Folders(testFolder).FolderPath = vbNullString Then
    SubFolderExists = True
  End If
    
errOut:
  On Error GoTo 0
End Function

Public Function Test()
  
End Function