Your basic ITPro blog... What's going on at work, what I'm interested in.

Monday, March 2, 2009

GMail’s Archive feature in Outlook…

I love this feature. This, plus GMail’s great search, keeps my Inbox clean while making all of my past mail easily accessible. Of course, all you GMailers out there already know this.

Now, when it comes to Outlook… well… not so much.

I used to just delete stuff and use the ‘Deleted Items’ folder as my archive folder. But, that is not really an ideal solution. So, I thought that I would create an Archive folder and then move message to that instead. After some searching, I found and modified a Macro. This code is not original to me. Unfortunately, I didn’t document where I got it, so I can’t give proper credit. I even searched some this morning, looking for the original again, with no luck. But, whoever you are, thank you!

Tie this to a button and a key combo, and you have a nice archive folder. Works great for me… My Inbox is clean and I know where to look for past emails.


Sub MoveMessages(strFolder As String)
    Dim olkItem As Object, _
        olkFolder As Outlook.MAPIFolder
    Set olkFolder = OpenMAPIFolder(strFolder)
    If TypeName(olkFolder) = "MAPIFolder" Then
        For Each olkItem In Application.ActiveExplorer.Selection
            olkItem.UnRead = False
            olkItem.Move olkFolder
    End If
    Set olkFolder = Nothing
    Set olkItem = Nothing
End Sub

Sub MoveTo_Archive()
    MoveMessages "\<MyMailbox>\_Archive"
End Sub

Function OpenMAPIFolder(szPath)
    Dim app, ns, flr, szDir, i
    Set flr = Nothing
    Set app = CreateObject("Outlook.Application")
    If Left(szPath, Len("\")) = "\" Then
        szPath = Mid(szPath, Len("\") + 1)
        Set flr = app.ActiveExplorer.CurrentFolder
    End If
    While szPath <> ""
        i = InStr(szPath, "\")
        If i Then
            szDir = Left(szPath, i - 1)
            szPath = Mid(szPath, i + Len("\"))
            szDir = szPath
            szPath = ""
        End If
        If IsNothing(flr) Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
            Set flr = flr.Folders(szDir)
        End If
    Set OpenMAPIFolder = flr
End Function

Function IsNothing(obj)
  If TypeName(obj) = "Nothing" Then
    IsNothing = True
    IsNothing = False
  End If
End Function


Nick said...

Derek, it's nice to know someone else shares the same fascination with wanting to archive most emails. What's wrong with using the Del key as the archive -- and Shift-Del to really delete? I've been doing it like this for 5+ years.

Derek Mangrum said...

Robert gets mad at me...


dhodge said...

i added the code as a macro, but each time i run it it opens the there something I am missing or need to setup first to get it to work?

Derek Mangrum said...

I am not sure what the issue would be. I have these 2 Subs and 2 Functions in a Module. Make sure you are calling the "MoveTo_Archive" sub. This is the Sub your Macro needs to be pointed to. It might be easiest to create this macro and then paste the code accordingly.

dhodge said...

can you send me a screen print...I only have one macro file
and it is just cut and pasted from the code from your page.

Derek Mangrum said...

I will write up another blog post with screencaps.

dhodge said...


Additional Info

My photo
email: support (AT) mangrumtech (DOT) com
mobile: 480-270-4332