Outlook PST Multiple Subfolders - Extract All Messages to One Folder at Once

Hierarchy of folders in Archive not necessary.

Need to extract all messages to one directory.

Any way to do this in a batch?  Rather than extracting them to the identical file structure, or selecting one by one each subfolder to go to a new single destination, run command that takes all mails out of every nested folder and dumps them into one folder in the new destination.


Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Bill PrewIT / Software Engineering ConsultantCommented:
You say "extract", does that mean you want them exported from Outlook to an O/S folder?  Or just  copied/moved to a new "flat" folder in Outlook?

oaktreesAuthor Commented:
Hi Bill! :))

Just  copied/moved to a new "flat" folder in Outlook.


Bill PrewIT / Software Engineering ConsultantCommented:
Okay, I'll see what I can work up .  A couple of additional questions.

  1. Do you want to move everything from the source folders, or only email items?  (there may only be email items, just trying to understand the filtering)
  2. Do you want to COPY or MOVE the items?

Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Bill PrewIT / Software Engineering ConsultantCommented:
This is a good starting point.  I didn't put any UI on it, didn't feel like that type of script.  But be aware, Outlook VBA doesn't give us a lot of good ways to show that it's busy or status while it's running.  So once you start it (test first of course) be patient since it will look like nothing is happening.  When it completes it displays a popup message box with a couple of counts from the process.

You need to specify the from and two folder paths near the top to start things off, then run the Flatten() procedure.

As coded it only moves Email items, and it MOVE's, not COPY's.  Easy to tweak those as needed.

Option Explicit

' Define global variables for statistics
Global lngCountFolders As Long
Global lngCountItems As Long

' Main procedure to move itens from a folder tree into a single folder
Sub Flatten()

    ' Initialize accumulators
    lngCountFolders = 0
    lngCountItems = 0

    ' Call recursive procedure to process folder and all child folders
    DoFolder GetFolderPath("\\basefolder\Inbox\Test1"), GetFolderPath("\\basefolder\Inbox\Test2")
    ' Show stats at the end
    MsgBox "Completed moving items" & vbCrLf & vbCrLf & _
           "  Folders processed = " & lngCountFolders & vbCrLf & _
           "  Items processed   = " & lngCountItems, _
           vbOKOnly, "Flatten Completed"

End Sub

' Recursive procedure to move items from a folder tree to a folder
Sub DoFolder(objFromFolder As Outlook.Folder, objToFolder As Outlook.Folder)
    Dim objSubfolder As Outlook.Folder
    Dim i As Long

    ' Make sure we have folder references
    If objFromFolder Is Nothing Or objToFolder Is Nothing Then
        Exit Sub
    End If

    ' Update counter
    lngCountFolders = lngCountFolders + 1

    ' Process each item in this folder, moving to destination folder
    For i = objFromFolder.Items.Count To 1 Step -1
        If objFromFolder.Items(i).Class = olMail Then
            lngCountItems = lngCountItems + 1
            objFromFolder.Items(i).Move objToFolder
        End If
    ' Process each subfolder of this folder (recursion)
    If objFromFolder.Folders.Count > 0 Then
       For Each objSubfolder In objFromFolder.Folders
           DoFolder objSubfolder, objToFolder
    End If

End Sub

' Get a folder object from a text folder path
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
    On Error GoTo GetFolderPath_Error
    ' Remove leading \\ if present
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    ' Start at the first node
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        ' Work through all the nodes in text path, chasing subfolders
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            ' Make sure we found a valid folder
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
    End If
    'Return the oFolder
    Set GetFolderPath = oFolder
    Exit Function
    Set GetFolderPath = Nothing
    Exit Function
End Function

Open in new window


Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
oaktreesAuthor Commented:
Hello Super BP!

A, A, A...AMAZING!  Will try to implement.  Please keep an eye on this question as I may need some help

Sincerest thanks!!! :)))

oaktreesAuthor Commented:
Thanks, BILL! :))))
Bill PrewIT / Software Engineering ConsultantCommented:

It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today

From novice to tech pro — start learning today.