Outlook inbox cleaner

By Rikard Ronnkvist, 2009-03-23 09:29 Good-to-have, VBScript

I like to keep my inbox clean… so every now and then I sort out mails to different folders. That is boooring.

So I wrote a little script. :-)

Sub InboxCleaner()
    Dim oNamespace As Outlook.NameSpace
    Dim oInboxFolder As Outlook.MAPIFolder
    Dim oDestFolder As Outlook.MAPIFolder
    Dim oItem As Object
    Dim i, iMove, iNoMove As Integer
    Dim sMsg, sFolder As String
    Dim bDoMove As Boolean

    Set oNamespace = Application.GetNamespace("MAPI")
    Set oInboxFolder = oNamespace.GetDefaultFolder(olFolderInbox)

    sMsg = ""
    iNoMove = 0
    iMove = 0

    For i = oInboxFolder.Items.Count To 1 Step -1
        Set oItem = oInboxFolder.Items(i)

        If InStr(oItem.SenderEmailAddress, "@") <> 0 Then
            sFolder = oItem.SenderEmailAddress ' Get sender address
            sFolder = Right(sFolder, Len(sFolder) - InStrRev(sFolder, "@")) ' Only domain name
            sFolder = Left(sFolder, InStr(sFolder, ".") - 1) ' Skip everything after the first dot
            sFolder = UCase(Left(sFolder, 1)) & Right(sFolder, Len(sFolder) - 1) ' Upper case first letter

            On Error Resume Next
            ' This row you might want to customize... I have a folders like  Mailbox\Customers\TheCustomerName
            Set oDestFolder = oInboxFolder.Folders.Parent.Parent.Folders("Customers").Folders(sFolder)

            If Err.Number <> 0 Then
                sMsg = sMsg & "Missing folder: " & vbTab & oItem.SenderEmailAddress & "  (" & sFolder & ")" & vbCrLf
                Set oDestFolder = Nothing
                Err.Clear
                bDoMove = False
                iNoMove = iNoMove + 1
            Else
                sMsg = sMsg & "Move:           " & vbTab & oItem.SenderEmailAddress & " -> " & sFolder & vbCrLf
                bDoMove = True
                iMove = iMove + 1
            End If
            On Error GoTo 0

            If bDoMove Then
                ' Comment out this line if you only want to test
                oItem.Move oDestFolder
            End If
        End If
    Next

    sMsg = sMsg & vbCrLf & _
        vbCrLf & _
        "Processed " & oInboxFolder.Items.Count & " items in inbox..." & vbCrLf & _
        "Moved:          " & vbTab & iMove & vbCrLf & _
        "Missing folder: " & vbTab & iNoMove & vbCrLf & _
        "Skipped:        " & vbTab & (oInboxFolder.Items.Count - (iMove + iNoMove))

    MsgBox sMsg, vbOKOnly, "Inbox Cleaner / Rikard Ronnkvist / snowland.se"

End Sub

Download: inboxcleaner.vbs

Update: Screendump of the result.
090323_inboxcleaner