Share via

Outlook: macro to move messages to another folder with conditions

One of forum users asked, if there was a possibility of creating a rule for incoming mail that would move messages with defined attributes. The main issue concerned moving older messages with a specified date, from Inbox to a defined folder.

Below you can find a macro, which can be triggered by a button, and works in every folder it is run in. Optionally, apart from the desired requirements, a feature of recognizing sender’s address, which the process refers to, was added.

Option Explicit

Sub MoveMess2Folder()
    'optionally it is possible to embed sender’s address and/or date of time limitation of creating a message
    Call MoveToFolder("VBATools", "vbatools@vbatools.pl", Now - 365)
End Sub

Function MoveToFolder(DestFolderName$, Optional MassageFrom$, Optional CreationTime As Date)
    'Machine by O'Shon
    Dim myOLApp As Application
    Dim myNameSpace As NameSpace
    Dim myInbox As MAPIFolder
    Dim objItem As MailItem
    Dim x&
    Dim oFolder As MAPIFolder
    Dim IoTask As Items

    If Application.ActiveExplorer.CurrentFolder.DefaultItemType <> 0 Then Exit Function
    myOLApp = CreateObject("Outlook.Application")
    myNameSpace = myOLApp.GetNamespace("MAPI")
    myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    IoTask = myInbox.Items
    oFolder = myOLApp.ActiveExplorer.CurrentFolder

    If Not FolderExists(myInbox, DestFolderName) Then
        MsgBox("Folder ''" & DestFolderName & "'' does not exist under ''" & myInbox & "'' folder" & _
        vbCr & "Create the folder ''" & DestFolderName & "'' or change VBACode.", vbExclamation, "VBATools.pl")
        Exit Function
    End If

    For x = IoTask.Count To 1 Step -1
        DoEvents()
        'Here you can add download and add a parameter value to progress indicator
        If IoTask.item(x).Class = 43 Then
            objItem = IoTask.item(x)
            'Debug.Print objItem.SenderEmailAddress & " " & objItem.Subject
            If Len(CreationTime) > 0 And Len(MassageFrom) > 0 Then
                If objItem.SenderEmailAddress = MassageFrom And _
                Format(objItem.CreationTime, "Short Date") <= Format(CreationTime, "Short Date") Then _
                objItem.Move(myInbox.Folders(DestFolderName))
            ElseIf Len(MassageFrom) > 0 And Len(CreationTime) = 0 Then
                If objItem.SenderEmailAddress = MassageFrom Then _
                objItem.Move(myInbox.Folders(DestFolderName))
            ElseIf Len(CreationTime) > 0 And Len(MassageFrom) = 0 Then
                If Format(objItem.CreationTime, "Short Date") <= Format(CreationTime, "Short Date") Then _
                objItem.Move(myInbox.Folders(DestFolderName))
            Else
                objItem.Move(myInbox.Folders(DestFolderName))
            End If
        End If
    Next

    objItem = Nothing
    oFolder = Nothing
    IoTask = Nothing
    myOLApp = Nothing
    myNameSpace = Nothing
    myInbox = Nothing
    objItem = Nothing
End Function

Function FolderExists(ByVal parentFolder As MAPIFolder, ByVal DestFolderName As String)
    'This Function code from www.outlookcode.com
    Dim tmpInbox As MAPIFolder
    On Error GoTo handleError
    tmpInbox = parentFolder.Folders(DestFolderName)
    FolderExists = True
    Exit Function
handleError:
    FolderExists = False
End Function

If you are not experienced in macro installation, please refer to this article.

See Also