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
Cloud 