Macro for Office 2016 - Move emails

[Caldasso]

Hello People

First, sorry for my english. I'm from Brazil.

I need a macro that moves emails based on their age.

Currently, my outlook looks like:

Exchange configuration

Inbox
|- subfolder 1
|- subfolder 2
|- subfolder 3
|- subfolder 4
|- subfolder 5
|- subfolder 6
|- subfolder 7

I receive emails in all folders, both in the inbox and in the subfolders.

I also have a data file (PST) with the same "format" as above. That is, as if it were a mirror ... however, this recorded place on the disc.

So I need a macro, which when I activate it, check all the exchange folders and move all emails older than 30 days into their local folders.

Someone of good heart, can you please help me?

[Logit]

.
https://www.slipstick.com/developer/...ove-aged-mail/

[Caldasso]

.

Thanks man.

But...

I do not have just the inbox. I have the inbox and several other subfolders. Emails are distributed via "rules" for each of the subfolders.

Follow an image:
email.jpg



So I need the macro to go from subfolder to subfolder by moving files over 1 month old to offline folders

[gmayor]

The following code will look through the sub folders

Sub Processfolders()
'Graham Mayor - http://www.gmayor.com - Last updated - 28 Oct 2017 
Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim subFolder As Folder
Dim olNS As Outlook.NameSpace
    Set cFolders = New Collection
    Set olNS = GetNamespace("MAPI")
    cFolders.Add olNS.PickFolder
    Do While cFolders.Count > 0
        Set olFolder = cFolders(1)
        cFolders.Remove 1

        'Do something here with olfolder e.g.
Debug.Print olFolder.Name

        For Each subFolder In olFolder.folders
            cFolders.Add subFolder
        Next subFolder
    Loop
lbl_Exit:
    Set olFolder = Nothing
    Set subFolder = Nothing
    Set olNS = Nothing
    Exit Sub
End Sub

[Caldasso]

Gmayor

Friend, sorry for my ignorance.
But I do not understand how to use your code.


From what I understand, your code should be used next to the other higher, right?

[gmayor]

You need to call the other code from it e.g. as follows. I have not tested the code, just made a couple of modifications to it to work with the folders derived from the Processfolders macro. It saves in a sub folder of Inbox called "Old" which must exist.

Option Explicit
'Graham Mayor - http://www.gmayor.com - Last updated - 31 Oct 2017

Sub Processfolders()
Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim subFolder As Folder
Dim olNS As Outlook.NameSpace
    Set cFolders = New Collection
    Set olNS = GetNamespace("MAPI")
    cFolders.Add olNS.PickFolder
    Do While cFolders.Count > 0
        Set olFolder = cFolders(1)
        cFolders.Remove 1
        'Do something here with olfolder e.g.
        MoveAgedMail olFolder
        For Each subFolder In olFolder.folders
            cFolders.Add subFolder
            DoEvents
        Next subFolder
    Loop
lbl_Exit:
    Set olFolder = Nothing
    Set subFolder = Nothing
    Set olNS = Nothing
    Exit Sub
End Sub

Sub MoveAgedMail(objSourceFolder As Outlook.MAPIFolder)

Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String

    Set objOutlook = Application
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    'Tell the macro where to store the messages here a folder called "Old" under inbox
    Set objDestFolder = objNamespace.GetDefaultFolder(olFolderInbox).folders("Old")
    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 days as needed.
            If intDateDiff > 30 Then
                objVariant.Move 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

[Caldasso]

Gmayor,

Thanks so much.

I ran a test, and he actually moved some emails. But that's not quite what I need.


The problem is that in the past, all moved emails are falling into the folder called "OLD"


I need these emails to fall into their same folders, however, in the PST file. As per the image I attached above.


That is, all emails from the "DELL" subfolder in the exchange, should go to the "DELL" subfolder in the PST. The same for each subfolder.


It is possible?


Thanks again!