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)
Next
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
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/
.