Run script to move incoming appointments based on date of appointment

[melly620]

I receive a lot of meeting requests that clog up my inbox and want to filter them into a folder ("Calendar Archive") so that I can check them just once a day UNLESS the meeting request/update is for today, in which case I'd like to move it to a different folder ("Appointments"). Essentially I want:

1. Check if item is a meeting request. If not, exit.
2. Check if meeting request is for today.
2a. If yes, move to Appointments folder.
2b. If no, move to Calendar Archive folder.

I've written some code so that I can create a rule that runs this as a script on all incoming mail but it doesn't seem to work. Any corrections would be much appreciated!


Sub CheckApptDate(Item As Outlook.MailItem)

If Item.MessageClass <> "IPM.Schedule.Meeting.Request" And Item.MessageClass <> "IPM.Schedule.Meeting.Canceled" Then
Exit Sub
End If

Dim myItem As Outlook.AppointmentItem
Set myItem = Item
Set ArchiveFolder = Application.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderInbox).Parent.Folders("Calendar Archive")
Set MainFolder = Application.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderInbox).Folders("Appointments")

If myItem.Start > Date Then
myItem.Move ArchiveFolder
Else
myItem.Move MainFolder
End If

End Sub

[skatonni]

Pass MeetingItem not Mailitem.

You will need this ' https://msdn.microsoft.com/en-us/library/office/ff867189.aspx

The code should look something like this:


Sub CheckApptDate(Itm As MeetingItem)

Dim myNS As Namespace
Dim myInbox As Folder
Dim myAppt As AppointmentItem
Dim ArchiveFolder As Folder
Dim MainFolder As Folder

Set myNS = GetNamespace("MAPI")

If Itm.MessageClass = "IPM.Schedule.Meeting.Request" Then

Set myAppt = Itm.GetAssociatedAppointment(True)
Set myInbox = myNS.GetDefaultFolder(olFolderInbox)
Set ArchiveFolder = myInbox.Parent.Folders("Calendar Archive")
Set MainFolder = myInbox.Folders("Appointments")

If myAppt.Start > Date Then
Itm.Move ArchiveFolder
Else
Itm.Move MainFolder
End If

End If

ExitRoutine:
Set myAppt = Nothing
Set myInbox = Nothing
Set ArchiveFolder = Nothing
Set MainFolder = Nothing

End Sub

Rules with the Run a Script option often break. If you experience this try changing to ItemAdd.