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.