Moving All Mail and Other Items from Outlook .PST Files/Subfolders to One .PST File/Folder

I found some useful code by Shirley Zhang from DataNumen recently in my quest to move all messages from multiple Outlook (Windows) .PST files, including all subfolders, into one folder in another open .PST file. Firstly, there’s this code to count all the messages in a .PST file, and secondly there’s this code to batch move all messages in a .PST file to another folder. The counting code is useful for checking if all messages have been successfully moved (alternating between source and target .PST files).

I just created a new .PST file by exporting an empty existing folder in Outlook to a new file, e.g. “All.pst”. Then, I opened up that .PST file and created an empty folder in it called “All”.

After running the move emails code on four or five .PST files, I realised that there were still some items left over, which turned out to be calendar items, contacts, and more. So I just expanded out an If… Then… Else statement in VBA to account for different item types. The last else usually catches the multiple types of meeting items (you could also manually check for all the olWhatever meeting classes). The modified code to move all items is below for reference.

Private Sub GetAllFolders()
    Dim objFolders As Outlook.Folders
    Dim objFolder As Outlook.Folder
 
    'Get all the folders in a specific PST file
    Set objFolders = Outlook.Application.Session.Folders("localhost").Folders
 
    For Each objFolder In objFolders
        Call MoveEmails(objFolder)
    Next
End Sub
 
Private Sub MoveEmails(ByVal objFolder As Outlook.Folder)
    Dim objTargetFolder As Outlook.Folder
    Dim objSubFolder As Outlook.Folder
    Dim i As Long
    Dim objAppointment As Outlook.AppointmentItem
    Dim objContact As Outlook.ContactItem
    Dim objDistributionList As Outlook.DistListItem
    Dim objJournal As Outlook.JournalItem
    Dim objMail As Outlook.MailItem
    Dim objNote As Outlook.NoteItem
    Dim objPost As Outlook.PostItem
    Dim objReport As Outlook.ReportItem
    Dim objTask As Outlook.TaskItem
    Dim objMeeting As Outlook.MeetingItem
 
    'Get the specific destination folder
    'You can change it as per your case
    Set objTargetFolder = Outlook.Application.Session.Folders("All").Folders("All")
 
    If objTargetFolder Is Nothing Then
       Set objTargetFolder = Outlook.Application.Session.Folders("All").Folders.Add("All")
    End If
 
    'Move each emails in the folder to the destination folder
    For i = objFolder.Items.Count To 1 Step -1
        If objFolder.Items.Item(i).Class = olAppointment Then
           Set objAppointment = objFolder.Items.Item(i)
           objAppointment.Move objTargetFolder
        ElseIf objFolder.Items.Item(i).Class = olContact Then
           Set objContact = objFolder.Items.Item(i)
           objContact.Move objTargetFolder
        ElseIf objFolder.Items.Item(i).Class = olDistributionList Then
           Set objDistributionList = objFolder.Items.Item(i)
           objDistributionList.Move objTargetFolder
        ElseIf objFolder.Items.Item(i).Class = olJournal Then
           Set objJournal = objFolder.Items.Item(i)
           objJournal.Move objTargetFolder
        ElseIf objFolder.Items.Item(i).Class = olMail Then
           Set objMail = objFolder.Items.Item(i)
           ' If objMail.DownloadState = olFullItem Then
           objMail.Move objTargetFolder
           ' End If
        ElseIf objFolder.Items.Item(i).Class = olNote Then
           Set objNote = objFolder.Items.Item(i)
           objNote.Move objTargetFolder
        ElseIf objFolder.Items.Item(i).Class = olPost Then
           Set objPost = objFolder.Items.Item(i)
           objPost.Move objTargetFolder
        ElseIf objFolder.Items.Item(i).Class = olReport Then
           Set objReport = objFolder.Items.Item(i)
           objReport.Move objTargetFolder
        ElseIf objFolder.Items.Item(i).Class = olTask Then
           Set objTask = objFolder.Items.Item(i)
           objTask.Move objTargetFolder
        Else
           ' MsgBox objFolder.Items.Item(i).Class, vbInformation + vbOKOnly, "Type"
           Set objMeeting = objFolder.Items.Item(i)
           objMeeting.Move objTargetFolder
        End If
    Next i
 
    'Process the subfolders in the folder recursively
    If (objFolder.Folders.Count > 0) Then
       For Each objSubFolder In objFolder.Folders
           Call MoveEmails(objSubFolder)
       Next
    End If
End Sub

You’ll see a few lines commented out: if you are offline, VBA will complain about header-only (not fully downloaded) mail messages, so uncommenting the olFullItem check will get around that; also, if VBA ends due to an unknown item type, you can uncomment the MsgBox to check what the return code is, then look that up here and add in another object type and else section. Even so, you may notice after the move that some new messages end up in your main account’s Drafts folder (these seem to be some mail drafts with other types of items added as attachments), and you can just drag these over to your aggregate folder in Outlook.

I also changed the count all items code to just focus on one .PST file. You can manually edit the name (currently set to “localhost”). This is the text name (or title) that appears in Outlook’s folders list for the .PST, not the file name, and is usually changed under Properties -> Advanced when right clicking on the folder in Outlook.

Sub CountAllItems_AllOutlookFiles()
    Dim objStores As Outlook.Stores
    Dim objStore As Outlook.Store
    Dim objOutlookFile As Outlook.Folder
    Dim i As Integer
    Dim lItemCount As Long
 
        Set objOutlookFile = Outlook.Application.Session.Folders("localhost")
        Call ProcessFolders(objOutlookFile.Folders, lItemCount)
 
        strlist = "All Items in " & Chr(34) & objOutlookFile.Name & Chr(34) & ": " & lItemCount & vbCr & strlist
  
    'Prompt you of the counts
    MsgBox strlist, vbInformation + vbOKOnly, "Item Count"
End Sub

Sub ProcessFolders(ByVal objCurFolders As Outlook.Folders, lCurCount As Long)
    Dim objFolder As Outlook.Folder
    Dim objSubFolder As Outlook.Folder
 
    'Count items
    For Each objFolder In objCurFolders
        lCurCount = objFolder.Items.Count + lCurCount
 
        If objFolder.Folders.Count > 0 Then
           Call ProcessFolders(objFolder.Folders, lCurCount)
        End If
    Next
End Sub