Copy mails from many subfolders to 1 foldr

Status
Not open for further replies.

ofw62

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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?

Thanks
=
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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:
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
        DoEvents
       
              objVariant.Move objDestFolder
              
              'count the # of items moved
               lngMovedItems = lngMovedItems + 1
      End If
    Next
         
nextfolder:
    Next
     ' 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
          
    Next
      
End Sub
 

ofw62

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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!

=
 
Status
Not open for further replies.
Top