Move Shared Outlook Folders/Subfolders and sub subfolders plus aged emails

[hogie]

Good morning everyone,

I'm struggling quite a bit here. I'm semi ok with basic VBA but this is beyond my skill level. In my department we have a shared email account/address for one of our teams. In this email account is a specific folder which is being used as an archive and it is huge. We are talking multiple sub folders (containing more subfolders) and emails that the department need to keep hold of under GDPR rules. The number of emails in these folders total to around 300,000 emails and the number of folders/sub folders/sub subfolders etc is approx 350.

What I need to do is to utilise some VBA code to copy the entire folder structure plus any emails that are over 365 days old into a different email account and then remove the emails that are over 365 days from the original email account leaving the same folder structure plus emails less than 365 days old in place in the original email account. The main folder in the email account is "01. Deal Folders" and the sub folders/ sub sub folders are all within that "01. Deals Folder" folder.

I found a piece of code on Slipstick.com that I thought would be a good starting point (Use a Macro to Move Aged Email in Outlook) and added some more code into it which i thought would take care of copying the folder structure and moving the aged emails. I know part of the issue is the code says "if found then move the entire folder", that's not what I want but I don't know the right code. Also the code I thought would work to replicate the folder structure isn't working either.

Is the scenario I am trying to achieve possible? If so, please could someone point me in the right direction?

Here is the code I have cobbled together using the code from Slipstick plus my own code mixed in:

Sub MoveAgedMail2()
 
'Get the function from http://slipstick.me/qf
    Dim objOutlook As Outlook.Application
    Dim objNamespace As Outlook.Namespace
    Dim objSourceFolder As Outlook.MAPIFolder
    Dim objDestFolder As Outlook.MAPIFolder
    Dim objVariant As Variant
    Dim lngMovedItems As Long
    Dim intCount As Integer
    Dim intDateDiff As Integer
    
    Dim objOwner As Outlook.Recipient
    Dim objowner2 As Outlook.Recipient
    
    Dim strSubFolder As String
    Dim olFolder As Folder
    Dim olSubFolder As Folder
    Dim Item As Outlook.MailItem
    Dim bExists As Boolean

    Set objOutlook = Outlook.Application
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    
    Set objOwner = objNamespace.CreateRecipient("email_1@dummyemailaddress.com")
    objOwner.Resolve
    Set objowner2 = objNamespace.CreateRecipient("email_2@dummyemailaddress.com")
    objowner2.Resolve
    
    If objOwner.Resolved Then
    Set objSourceFolder = objNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox).Folders("01. Deal Folders")
    End If
    On Error Resume Next
    Set objDestFolder = objNamespace.GetSharedDefaultFolder(objowner2, olFolderInbox) .Folders("01. Deal Folders")
     
 'Use a folder in a different data file
 With Item
        
        strSubFolder = objSourceFolder
 
        Set olFolder = objDestFolder
        For Each olFolder In olFolder.Folders
        
            For Each olSubFolder In olFolder.Folders
                If olFolder.Name = strSubFolder Then
                    bExists = True
                    Exit For
                End If
                If olSubFolder.Name = strSubFolder Then
                    bExists = True
                    Exit For
                End If
            Next olSubFolder
        Next olFolder
        If Not bExists Then
            Set olSubFolder = olFolder.Folders.Add(strSubFolder)
        End If
        Item.Move olSubFolder
    End With
 
   
    For intCount = objSourceFolder.Items.Count To 1 Step -1
        Set objVariant = objSourceFolder.Items.Item(intCount)
        DoEvents
        If objVariant.Class = olMail Then
             
             intDateDiff = DateDiff("d", objVariant.SentOn, Now)
              
           ' adjust number of days as needed.
            If intDateDiff > 365 Then

              objVariant.Move olSubFolder 'objDestFolder
               
              'count the # of items moved
               lngMovedItems = lngMovedItems + 1

            End If
        End If
    Next
     
    ' Display the number of items that were moved.
    MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objDestFolder = Nothing
End Sub