Outlook 2016 Copy mails from many subfolders to 1 foldr

Discussion in 'Using Outlook' started by ofw62, May 8, 2017.

  1. ofw62


    Senior Member
    I have this archive.pst

    Within it, there are a lot of folders, sub folder, sub-sub folders...
    I would like to have all the separate mails copied (or moved) to 1 folder. The reason behind this is a long story.

    Right now, I have to go thru all the individual folders one-by-one and then select-copy all the mails to a new 'main' folder.

    Q: Is there an easier way to do this?

  2. Diane Poremsky

    Diane Poremsky

    Senior Member
    Select all (ctrl+a), move to folder command or drag is the easiest non-macro way... a macro could do it with less manual effort. Because you are moving all messages to one folder, testing it is less of a worry - not much it can screw up, but going to the wrong folder or missing some messages.

    you'd use a variation of the macro at Print a list of your Outlook folders - rather than printing folder names, you move the contents. (Use a Macro to Move Aged Email in Outlook shows how to move messages).

    you can run the print list of folders macro when you are done - if all folder count is 0 then you are done.

    this worked here in a test - BUT - it moves the messages to the default data file's inbox. if the folder is elsewhere, you need to use GetFolderPath function at Working with VBA and non-default Outlook Folders to properly identify the folder.

    Run it on a parent folder, not the top level of the mailbox - it's supposed to check that the items are mailitems, but just in case it doesn't, move any non-mail subfolders (calendar & contacts etc) you might have, out of the subfolders.

    Code (Text):
    Copy Source

    Public strFolders As String
    Public Sub GetFolderNames()
        Dim olApp As Outlook.Application
        Dim olNS As Outlook.NameSpace
        Dim olStartFolder As Outlook.MAPIFolder
        Dim lCountOfFound As Long
        lCountOfFound = 0
        Set olApp = New Outlook.Application
        Set olNS = olApp.GetNamespace("MAPI")
        Set olStartFolder = olNS.PickFolder
        ProcessFolder olStartFolder
    End Sub
    Sub ProcessFolder(CurrentFolder As Outlook.MAPIFolder)
        Dim i As Long
        Dim olNewFolder As Outlook.MAPIFolder
        Dim olTempFolder As Outlook.MAPIFolder
        Dim olTempFolderPath As String
         ' Loop through the items in the current folder.
        Set objDestFolder = Session.GetDefaultFolder(olFolderInbox)
        For i = CurrentFolder.Folders.Count To 1 Step -1
            Set olTempFolder = CurrentFolder.Folders(i)
           If olTempFolder.Name = "Inbox" Then GoTo nextfolder
            olTempFolderPath = olTempFolder.FolderPath
         ' Get the count of items in the folder
             olCount = olTempFolder.Items.Count
         'prints the folder path and name in the VB Editor's Immediate window
             Debug.Print olTempFolderPath & " " & olCount
        On Error Resume Next
        For intCount = olCount To 1 Step -1
            Set objVariant = olTempFolder.Items.Item(intCount)
            If objVariant.Class = olMail Then
                  objVariant.Move objDestFolder
                  'count the # of items moved
                   lngMovedItems = lngMovedItems + 1
          End If
         ' Loop through and search each subfolder of the current folder.
        For Each olNewFolder In CurrentFolder.Folders
             'Don't need to process the Deleted Items folder
            If olNewFolder.Name <> "Deleted Items" Then
                ProcessFolder olNewFolder
            End If
    End Sub
  3. ofw62


    Senior Member
    Hi Diana, Thanks for the above. I am deeply sorry for the delay. Was away for some time.
    To be honest, whilst I do appreciate your above code, I am sorry to say: I hesitated to apply it
    (considering your 'reservations'), so I went on to handle the matter 'manually'.
    It took a while but then again there were no unforeseen results.
    Once again, thanks!


Share This Page