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
Next
' 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
Next

' Then copy all items in the folder
For Each objMailToMove In objFolderFromFolder.Items
objMailToMove.move objFolderToFolder
Next
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.

Advertisement