Inbox Zen/Download

From KMWiki

This is barebones at the moment. To install, open outlook, press ALT-F11, copy & paste the code into the "ThisOutlookSession" module. Restart outlook. I apologise if that's too scary for you, I'm working on an easier way.

Terms of use:

• if you really like it, share it!
• consider our Creative Commons license
• tell me you like it (I'm vain). You can also tell me if it doesn't work.
• pay it forward by donating to cancer research
• um, don't resell my code, or distribute for commercial use. Please let me kno
• Knowledgethoughts.com is not responsible the impact the macro has on outlook, your computer, or otherwise. By installing this code on your computer, you accept full responsibility for any *Knowledgethoughts.com provides the code "as is" and will not support it in any way

The code

Public gRuleNote As Outlook.NoteItem
Public gRuleDic As Scripting.Dictionary
Public gRuleDate As Date
Public Function IsNothing(pvarToTest As Variant) As Boolean
    On Error Resume Next
    IsNothing = (pvarToTest Is Nothing)
    Err.Clear
    On Error GoTo 0
End Function

Public Function OutlookFolderNames(objFolder As Outlook.MAPIFolder, strFolderName As String) As Object
'*********************************************************
    On Error GoTo ErrorHandler
    Dim objOneSubFolder As Outlook.MAPIFolder
    If Not objFolder Is Nothing Then
        If LCase(strFolderName) = LCase(objFolder.Name) Then
            Set OutlookFolderNames = objFolder
        Else
            ' Check if folders collection is not empty
            If objFolder.Folders.Count > 0 And _
                   Not objFolder.Folders Is Nothing Then
                For Each oFolder In objFolder.Folders
                    Set objOneSubFolder = oFolder
                    ' only check mail item folder
                    If objOneSubFolder.DefaultItemType _
                         = olMailItem Then
                        If LCase(strFolderName) = _
                          LCase(objOneSubFolder.Name) Then
                            Set OutlookFolderNames = _
                                   objOneSubFolder
                            Exit For
                        Else
                        
                            If objFolder = "Projects" Then
                                x = "y"
                            End If
                            
                            If objOneSubFolder.Folders.Count > 0 Then
                                Set OutlookFolderNames = OutlookFolderNames(objOneSubFolder, strFolderName)
                                If Not (IsNothing(OutlookFolderNames)) Then
                                    Exit For
                                End If
                                
                            End If
                        End If
                    End If
                Next
            End If
        End If
    End If

    Exit Function

ErrorHandler:
    Set OutlookFolderNames = Nothing
End Function
Public Sub inboxZen()
'    ResumeClickYes
    Call checkSettings

    Dim oMAPI As Outlook.NameSpace
    Dim oInbox As Outlook.MAPIFolder
    Dim objFolder As Outlook.MAPIFolder
        
    Set oMAPI = GetObject("", "Outlook.application").GetNamespace("MAPI")
    Set oInbox = oMAPI.GetDefaultFolder(olFolderInbox)
    
    Dim destFolder As String
    
    Dim sClassComp As String
    sClassComp = "IPM.Note"     'mailtype
    sClass2Comp = "IPM.Note.EnterpriseVault.Shortcut" 'vaulttype

    On Error GoTo err_1
    
    Dim counter As Integer

    For counter = oInbox.Items.Count To 1 Step -1
        Set msg = oInbox.Items(counter)
        Dim tmp As MailItem
        If (msg.MessageClass = sClassComp Or msg.MessageClass = sClass2Comp) Then
        
            Set tmp = msg
            destFolder = ""
            
            If Len(tmp.Categories) > 0 Then
                
                Dim catKey As String
                catKey = tmp.Categories
                
                If (gRuleDic.Exists(catKey)) Then
                 destFolder = gRuleDic.Item(LCase(catKey))
                
                 If Len(destFolder) > 0 Then
                     Set objFolder = OutlookFolderNames(oInbox, destFolder)
                     Dim newmail As MailItem
                     Set newmail = tmp.Move(objFolder)
                 End If
                End If
            End If
        
        End If
        
    Next
    
    
    Exit Sub

err_1:
    
    MsgBox "oops"
    Dim tmp2
    tmp2 = Err
    
End Sub

Private Sub Application_NewMail()
    Call inboxZen  '(off by default due to outlook security guard)
End Sub


Public Sub findFilingRules(filingRuleNote As Outlook.NoteItem)
        
    Dim rules As New Scripting.Dictionary
    Dim ruleText As String
    Dim currentRule As String
    
    Dim counter As Integer
    
    
    ruleText = Replace(filingRuleNote.Body, Chr(10), "~", , , vbTextCompare)
    ruleText = Replace(ruleText, Chr(13), "", , , vbTextCompare)
    
    counter = InStr(1, ruleText, "~", vbTextCompare) + 1
    
    While InStr(counter, ruleText, "|", vbTextCompare) > 0
        endOfLine = InStr(counter + 2, ruleText, "~", vbTextCompare) - counter
        If (endOfLine < 0) Then
            endOfLine = Len(ruleText) - counter + 1
        End If
        
        currentRule = Mid(ruleText, counter, endOfLine)
        ruleKey = getFirst(currentRule)
        ruleValue = getLast(currentRule)
        Call rules.Add(ruleKey, ruleValue)
        counter = counter + endOfLine + 1
    Wend
    
    Set gRuleDic = rules
    gRuleDate = filingRuleNote.LastModificationTime
    Set gRuleNote = filingRuleNote
    
    
    
noaccess:
    
    
End Sub

Public Function getFirst(currentRule) As String
    Dim commaLocation As Integer
    commaLocation = InStr(1, currentRule, "|", vbTextCompare)
    getFirst = Mid(currentRule, 1, commaLocation - 1)
End Function

Public Function getLast(currentRule) As String
    Dim commaLocation As Integer
    commaLocation = InStr(1, currentRule, "|", vbTextCompare)
    getLast = RTrim(Mid(currentRule, commaLocation + 1, Len(currentRule) - commaLocation))
End Function

Public Sub checkSettings()

    Dim oMAPI As Outlook.NameSpace
    Dim oNotes As Outlook.MAPIFolder
    Dim renew As Boolean
    renew = False
    
    If IsEmpty(gRuleDate) Then
        renew = True
    ElseIf gRuleDate = "00:00:00" Then
        renew = True
    ElseIf gRuleDate < CDate(gRuleNote.LastModificationTime) Then
        renew = True
    End If
    
    If (renew) Then

        Set oMAPI = ThisOutlookSession.Application.GetNamespace("MAPI")
        Set oNotes = oMAPI.GetDefaultFolder(olFolderNotes)
        Dim note As Outlook.NoteItem
                
        For Each note In oNotes.Items
            If note.Subject = "@filingRules" Then
                Call findFilingRules(note)
                Exit Sub
            End If
        Next
    
        Set note = oNotes.Items.Add(olNoteItem)
        note.Body = "@filingNotes" + Chr(10) + "shortcut|foldername"
        Call note.Display
        MsgBox ("The cloudy mind sees nothing." + Chr(10) + Chr(10) + "Thank you for installing InboxZen from KnowledgeThoughts")
    
    End If
    
End Sub


Public Sub installToolbars()
    Dim oMAPI As Outlook.NameSpace
    Set oMAPI = GetObject("", "Outlook.application").GetNamespace("MAPI")
    
    Dim ex As Outlook.Explorer
    Dim cb As Office.CommandBar
    
    On Error Resume Next
    oMAPI.Application.ActiveExplorer.CommandBars("inboxZenBar").Delete
    Set cb = oMAPI.Application.ActiveExplorer.CommandBars("Standard")
    
    For Each Button In cb.Controls
        If Button.Caption = "Inbox&Zen" Then
            Exit Sub
        End If
    Next
    
    Dim cbutton As Office.CommandBarButton
    Set cbutton = cb.Controls.Add(msoControlButton, , "inboxZenProj.ThisOutlookSession.inboxZen", , False)
    With cbutton
        .Style = msoButtonIconAndCaption
        '.Parameter = "inboxZenProj.ThisOutlookSession.inboxZen"
        .OnAction = "inboxZenProj.ThisOutlookSession.inboxZen"
        .Caption = "Inbox&Zen"
        
        .State = msoButtonUp
        .FaceId = 59
        .Tag = "izen"
    End With
    cbutton.Enabled = True
    
End Sub

Public Sub ListCommandBarControlIDs()

    ' Purpose: Lists all command bar control IDs for the
    ' current application.
    
    Dim objCommandBar As Office.CommandBar
    Dim objCommandBarControl As Office.CommandBarControl
    
    ' Replace the next line with:
    For Each objCommandBar In Application.Explorers(1).CommandBars
    
        For Each objCommandBarControl In objCommandBar.Controls
        
            Debug.Print objCommandBarControl.Caption & " " & _
                objCommandBarControl.ID
            
        Next objCommandBarControl
    
    Next objCommandBar
    
End Sub


Private Sub Application_Startup()
    Call checkSettings
    installToolbars
End Sub