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:
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:
VBA Code:
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