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