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!

[VBA]
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
[/VBA]

[skatonni]

Pass MeetingItem not Mailitem.

You will need this ' https://msdn.microsoft.com/en-us/lib.../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.