Outlook

Controlling your Outlook Inbox

VBA, , Leave a comment

Do you wish there was a magic bullet to control your Outlook inbox? There are all kinds of management theories like GTD (Getting things done), FIFO (First In First Out), Least Effort, Inbox Zero, etc. While these are all effective management techniques if implemented correctly, the problem is that the reality is different than theory.

Personally, I *try* to practice Inbox Zero. I get around 500 work email messages daily, not all of which I need to deal with. Many are server notifications, group notifications, company-wide emails, etc. These are easy to filter out with Outlook rules and are sent to different folders that I peruse at my leisure. Beyond that, anything that isn’t addressed to me directly, e.g. sent to me as part of a group, goes to a different folder as well. I also delete all emails that I reply to because I save Sent items and it makes more sense to save the email thread with my reply. At this point, I feel my Inbox is “manageable”. My REAL problem is that it is not deemed manageable by my Outlook system administrators. I am allotted 100MB for my mailbox before I am placed in “email jail”. Beyond that, I can receive emails, but may not be able to send. Don’t ask me how they do this or why, I don’t really care because it happens (seriously though, disk space is the cheapest IT investment you can make).

What I’ve found is that I get lots of attachments from people. Lots and lots and lots of attachments and they aren’t small either. With my kind of limit, it would take only 50 2MB attachments to fill up my space (if only 10% of my daily volume has attachments I’m done. The reality is that I deal with other accountants, and accountants LOVE spreadsheets, especially really, really big ones. It’s not uncommon when a problem arises to see a 20-30MB bad boy flop into my inbox). The irony is that I have 100GB of personal space on our servers. (For those wondering, Outlook is on SAN space and “personal” drives are a NAS mount, so there’s a huge cost difference.) Many people in this situation would go with an aggressive archiving process. The problem with this is that

  1. Now I have to search the “archive” folders for even recent email (7 days or more for me)
  2. Storing all those attachments on the mail messages is extremely inefficient

I haven’t done the math, but searching for messages with attachments doesn’t seem to run any faster than an ordinary search. Combine that with the larger my .pst file gets, the slower searches seem to be and I’m motivated to keep my archive as small as possible. To do that, I do not archive attachments. Instead, every couple of days I run a script that will take all the emails in a given folder (one I select) and either save or delete the attachments. When I choose save, it saves the files using the Sender Name and attachment. So if someone says they sent me something, I go to my “Attachments” folder on my personal drive, sort on their name, and find the file name.

So here’s how I do it. I have a VB form defined with the following code in Outlook (this it 2003 tested). The form prompts you for a folder and whether you want to save or delete the attachments. If you pick save, you’re prompted for a file location. After that, the script iterates the messages in the folder and performs the requested action on the attachments. In all cases it removes the attachment from the selected message. If you’re paranoid, it writes plenty of debug statements, so you can always watch it run or you can comment out line 174 below (highlighted).

'Global Variables
  Dim app As New Outlook.Application
  Dim ns As Outlook.NameSpace
  Dim root As Outlook.MAPIFolder
  Dim strFolder As String
  Dim objSelFolder As Outlook.MAPIFolder

Private Sub cmbFolders_Change()
  UnIterateSub cmbFolders.Value
End Sub

Private Sub cmdExecute_Click()
  If Opt1.Value = True Then
    Attachments objSelFolder, True
  Else
    Attachments objSelFolder, False
  End If
End Sub

Private Sub Opt1_Click()
  strFolder = GetFolder()
End Sub

Private Sub UserForm_Activate()
  Set app = CreateObject("Outlook.Application")
  Set ns = app.GetNamespace("MAPI")
  LoadFolderList
End Sub

'Call List Builder
Sub LoadFolderList()
  Set root = ns.GetDefaultFolder(olFolderInbox).Parent
  IterateSub root.Folders, 0, ""
End Sub

'Build list of folders for current mailbox
Sub IterateSub(fgrp As Outlook.Folders, intCounter As Integer, strParent As String)
  Dim fsub As Outlook.MAPIFolder
  Dim intLoc As Integer
  intLoc = 0
  Set fsub = fgrp.GetFirst
  
  Do While Not fsub Is Nothing
    strParent = strParent & "\" & fsub.Name
    Debug.Print fsub.Name, fsub.Folders.Count, intCounter, strParent
    cmbFolders.AddItem strParent
    If fsub.Folders.Count > 0 Then
      intCounter = intCounter + 1
      IterateSub fsub.Folders, intCounter, strParent
    Else
      If strParent <> "" Then
        intLoc = InStrRev(strParent, "\")
        strParent = Left(strParent, intLoc - 1)
      End If
    End If
    Set fsub = fgrp.GetNext
  Loop
    If intCounter <> 0 Then
      intCounter = intCounter - 1
    End If
    If strParent <> "" Then
      intLoc = InStrRev(strParent, "\")
      strParent = Left(strParent, intLoc - 1)
    End If
End Sub

'Reset location on change of folder
Sub UnIterateSub(strFolderValue As String)
  Dim x
  Dim arrFolders As Variant
  arrFolders = Split(strFolderValue, "\")

  For x = 1 To UBound(arrFolders)
    If x = 1 Then
      Set objSelFolder = root.Folders(arrFolders(x))
    Else
      Set objSelFolder = objSelFolder.Folders(arrFolders(x))
    End If
  Next
  Debug.Print "Output from: ", objSelFolder.Name
End Sub

'============================================================
' Module will open a File Dialog and allow users to select
' folder to save to
' Source: MS website
'============================================================
Function GetFolder()
'Declare a variable as a FileDialog object.
    Dim fd As FileDialog

    'Create a FileDialog object as a File Picker dialog box.
    Set fd = Access.Application.FileDialog(msoFileDialogFolderPicker)

    'Declare a variable to contain the path
    'of each selected item. Even though the path is a String,
    'the variable must be a Variant because For Each...Next
    'routines only work with Variants and Objects.
    Dim vrtSelectedItem As Variant

    'Use a With...End With block to reference the FileDialog object.
    With fd

        'Allow the selection of multiple files.
        .AllowMultiSelect = False

        'Use the Show method to display the file picker dialog and return the user's action.
        'If the user presses the action button...
        If .Show = -1 Then

            'Step through each string in the FileDialogSelectedItems collection.
            For Each vrtSelectedItem In .SelectedItems

                'vrtSelectedItem is a String that contains the path of each selected item.
                'You can use any file I/O functions that you want to work with this path.
                'This example simply displays the path in a message box.
                'MsgBox "Selected item's path: " & vrtSelectedItem
                GetFolder = vrtSelectedItem
            Next
        'If the user presses Cancel...
        Else
        End If
    End With

    'Set the object variable to Nothing.
    Set fd = Nothing

End Function

'============================================================
' Module will save or delete attachments depending on selection
' Inputs: Folder (folder object), Save (boolean: true = save)
'============================================================
Sub Attachments(objFolder As Outlook.MAPIFolder, boolSave As Boolean)
On Error Resume Next

  If boolSave And strFolder = "" Then
    MsgBox "If you want to save your attachments, you will need to select a directory to save to", vbOKOnly, "No Directory Selected"
    GetFolder
    Exit Sub
  End If

  'Declare Variables
    Dim colItems
    Dim objMessage As MailItem
    Dim intCount As Integer
    Dim i
    Dim strExtension As String
    Const olFolderInbox = 6

    'Set objects
    Set colItems = objFolder.Items

    'Begin loop through all messages in folder (Inbox)
    For Each objMessage In colItems
      intCount = objMessage.Attachments.Count
      'Check for attachments
      If intCount > 0 Then
      'Debug.Print objMessage.SenderName, objMessage.Subject
        'Begin loop to save attachments individually
        If boolSave Then
          For i = 1 To intCount
            strExtension = Right(objMessage.Attachments.Item(i).FileName, 3)
            If strExtension <> "bmp" And strExtension <> "gif" And strExtension <> "jpg" And strExtension <> "tif" Then
              Debug.Print strFolder & "\" & objMessage.SenderName & "_" & objMessage.Attachments.Item(i).FileName
              objMessage.Attachments.Item(i).SaveAsFile strFolder & "\" & objMessage.SenderName & "_" & _
                  objMessage.Attachments.Item(i).FileName
            End If
          Next
        End If
        'Remove attachments from message
        'Comment this line out if you're paranoid
        For i = 1 To intCount
          objMessage.Attachments.Remove i
        Next
        
      'Save message (not completely necessary)
      objMessage.Save
    End If
  Next
  
  MsgBox "Process Completed"
End Sub

A couple of notes:

  • Add a reference to Access in the library because that’s what I use for the folder select.
  • It does not save common image formats (bmp, gif, jpg) because lots of people use them in signatures.
  • You will have to change your Macro permissions if you choose to not personally sign the macro, probably to Medium. Do not turn them off or change to Low. That’s just stupid.

The form is linked here as a “.doc”. You’ll need to rename it to a “.frx” to use it. Save the above code as “frmAttachment.frm”, import the .frx to Outlook and you should be ready to rock.

Run at your discretion and Voila! More space.

HTH