Cleaning up 10 years of outlook history

When upgrading to Vista and Outlook 2007, I decided to go through various backups and get 10 years of outlook use into one mailbox file (outlook.pst). After collecting several different .pst files, I opened all in Outlook. Thereafter I moved mail messages from the backup .pst files into the current one. However, then a problemed surfaced: When moving a folder hierarchy of mails (e.g. “personal folders\archive\…”) between an old .pst file into a new one with an identical folder hierarchy outlook automatically create a sequence numbered folder (e.g. “personal folders\archive1\…”). This was not what I wanted, and not what you are used to when moving files around your harddisk(in that case you get a replace question or something like that).

Anyway, there was no easy solution here, other than going through that hierarchy and copying the contents of each subfolder in the backup .pst to the similar subfolder in the target .pst. After pondering about for close to an hour, I created this macro vbscript to do the job:

Option Explicit

Sub MoveToArkiv()

Dim objFolder As Outlook.MAPIFolder
Dim objFolderFromBase As Outlook.MAPIFolder
Dim objFolderToBase As Outlook.MAPIFolder

Set objFolder = Application.Session.Folders.Item("Personal Folders")

' Set the two next lines to the approprite to and from folders
Set objFolderFromBase = objFolder.Folders.Item("Arkiv3")
Set objFolderToBase = objFolder.Folders.Item("Arkiv")

' Recursively go thorugh the folders and subfolders, moving every item
MoveItems objFolderFromBase, objFolderToBase

End Sub

Sub MoveItems(objFolderFromFolder As Outlook.MAPIFolder, objFolderToFolder As Outlook.MAPIFolder)

Dim objFolderSource As Outlook.MAPIFolder
Dim objFolderTemp As Outlook.MAPIFolder
Dim objFolderTarget As Outlook.MAPIFolder
Dim blnFound As Boolean
Dim objMailToMove As Outlook.MailItem

For Each objFolderSource In objFolderFromFolder.Folders
blnFound = False
' check whether a similar folder exist in target
For Each objFolderTemp In objFolderToFolder.Folders
If objFolderTemp.Name = objFolderSource.Name Then
Set objFolderTarget = objFolderTemp
blnFound = True
End If
' If not found, create
If Not blnFound Then
Set folderTarget = folderToFolder.Folders.Add(folderSource.Name)
End If

' For each subfolder runs this procedure
MoveItems objFolderSource, objFolderTarget

' Then copy all items in the folder
For Each objMailToMove In objFolderFromFolder.Items
objMailToMove.move objFolderToFolder
End Sub

To use it edit the two lines at the top to set the correct base folders for moving from and moving to. The script was used with Outlook 2007 but should work on Outlook 2003 as well.

3 thoughts on “Cleaning up 10 years of outlook history

  1. Mike says:

    in the creation of new folder

    If Not blnFound Then
    Set folderTarget = folderToFolder.Folders.Add
    End If

    shouldn’t that be
    set objFolderTarget ….


  2. Mike says:

    and shouldn’t it also be (same statement)

    set objFolderTarget = objFolderToFolder.Folders.Add(….)

    otherwise it’s a fine piece of code – well done!


Leave a Reply

Fill in your details below or click an icon to log in: Logo

You are commenting using your account. Log Out /  Change )

Google photo

You are commenting using your Google account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s