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 http://www.outlookcode.com/codedetail.aspx?id=50

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: https://www.kunal-chowdhury.com/2017/12/force-load-outlook-addin.html

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.

donot-disable-outlook-addin-create-dword-key

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

donot-disable-outlook-addin-set-dword-value

Windows Registry Editor Version 5.00  

[HKEY_CURRENT_USER\Software\Policies\Microsoft\Office\1x.0\Outlook\Resiliency\AddinList] 
"ADDIN_NAME"="1" 

[HKEY_CURRENT_USER\SOFTWARE\Microsoft\Office\Outlook\Addins\ADDIN_NAME] 
"LoadBehavior"=dword:00000003 

[-HKEY_CURRENT_USER\SOFTWARE\Microsoft\Office\1x.0\Outlook\Resiliency\DisabledItems] 

[HKEY_CURRENT_USER\SOFTWARE\Microsoft\Office\1x.0\Outlook\Resiliency\DisabledItems] 

[-HKEY_CURRENT_USER\SOFTWARE\Microsoft\Office\1x.0\Outlook\Resiliency\CrashingAddinList] 

[HKEY_CURRENT_USER\SOFTWARE\Microsoft\Office\1x.0\Outlook\Resiliency\CrashingAddinList] 

[HKEY_CURRENT_USER\SOFTWARE\Microsoft\Office\1x.0\Outlook\Resiliency\DoNotDisableAddinList] 
"ADDIN_NAME"=dword:00000001 

[HKEY_CURRENT_USER\SOFTWARE\Microsoft\Office\1x.0\Outlook\Resiliency\NotificationReminderAddinData] 
"ADDIN_NAME\dtype"=dword:00000000 

[HKEY_CURRENT_USER\SOFTWARE\Microsoft\Office\1x.0\Outlook\Resiliency\NotificationReminderAddinData] 
"ADDIN_NAME"=dword:967a844d

https://developermessaging.azurewebsites.net/2017/08/02/outlooks-slow-add-ins-resiliency-logic-and-how-to-always-enable-slow-add-ins/