Sorting Outlook Emails into Subfolders

Sub MoveEmailToStorageFormatted()

 'On Error Resume Next

    Dim curMail As Outlook.MailItem

 For x = 1 To Application.ActiveExplorer.Selection.count

 Debug.Print x

    Set curMail = GetCurrentItem(x)


    Call MoveAndFormat(curMail)


End Sub

Sub CreateFolders(sPath, level, ByRef oFolder As Folder)

  On Error Resume Next


  sLevel = Split(sPath, "\")(level)

  Debug.Print "sLevel = " & sLevel & vbTab & "Level = " & level

  If Len(sLevel) > 0 Then

   'If IsNull(oFolder.Folders(sLevel)) Then

    Debug.Print "IsNull"

    Debug.Print "Adding: " & sLevel

    oFolder.Folders.Add sLevel

    Set oFolder = oFolder.Folders(sLevel)

     Call CreateFolders(sPath, level + 1, oFolder)

   'End If

 End If



  On Error GoTo 0

End Sub


    Sub CreateFolder(ByVal strPath)

        On Error Resume Next


        If Not objFSO.FolderExists(objFSO.GetParentFolderName(strPath)) Then Call CreateFolder(objFSO.GetParentFolderName(strPath))

        objFSO.CreateFolder (strPath)

        On Error GoTo 0

    End Sub



' From

Function GetCurrentItem(x) As Object

    Dim objApp As New Outlook.Application


    'Set objApp = CreateObject("Outlook.Application")

    On Error Resume Next

    Select Case TypeName(objApp.ActiveWindow)

        Case "Explorer"

            Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(x)

        Case "Inspector"

            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem

        Case Else

            ' anything else will result in an error, which is

            ' why we have the error handler above

    End Select


    Set objApp = Nothing

End Function

Sub MoveAndFormat(themail As MailItem)

On Error Resume Next

 Dim xFolder As Folder, out As Folder


'Set xFolder = Application.session.Folders.Item("Inbox")

' Item Can be Mailbox - <first> <lastname>

Set xFolder = Application.session.Folders.Item("Mailbox - Rich Lemmermann")



  Debug.Print themail.SenderName

  Debug.Print themail.SentOn & vbTab & Year(themail.SentOn)

  sDestFolder = "Inbox\" & Year(themail.SentOn) & "\" & themail.SenderName

 Call CreateFolders(sDestFolder, 0, xFolder)


 Set out = GetFolder(sDestFolder, 0, xFolder)

 Debug.Print out.Name

 themail.UnRead = False


 themail.Move out


End Sub

Function GetFolder(sPath, level, oFolder)

  On Error Resume Next

  sLevel = Split(sPath, "\")(level)

  Debug.Print "sLevel = " & sLevel & vbTab & "Level = " & level

  If Len(sLevel) > 0 Then


    Set oFolder = oFolder.Folders(sLevel)

    Call GetFolder(sPath, level + 1, oFolder)

  End If


  Set GetFolder = oFolder


  On Error GoTo 0

End Function

Slow Addin Fix for Outlook 2013 and 2016

i found out that i was nearly there. you have to find the addins from another key and then put them in the DoNotDisableAddinList key

This is taken from:

HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Outlook\Addins, where '16.0'  


Next step is to force Outlook to load the add-in, even though it is performing slow during Outlook loading time. For this, navigate to the registry path: HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Outlook\Resiliency\DoNotDisableAddinList and create a DWORD registry KEY. Give it the same name of the add-in that you copied from the previous section. 


Now, set the DWORD value to '1' to ask the system to always enable it: 


Windows Registry Editor Version 5.00