Question

I am trying to delete future appointments in my Outlook calendar, from Access VBA, with the code below. The code works ok, BUT those Appointments have been set up using a room (resource), and deleting the appointment in MY calendar does not delete it in the resource calendar. How can I fix that ?

Sub NoFuture()
    'delete any future appointment
    Dim olApp As Outlook.Application
    Dim olNs As Outlook.NameSpace
    Dim olRecItems
    Dim olFilterRecItems
    Dim olItem As Outlook.AppointmentItem, strFilter As String

    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set olRecItems = olNs.GetDefaultFolder(olFolderCalendar)

    strFilter = "[Start] > '" & Format(Date + 1, "mm/dd/yyyy") & "'"
    Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)

    For Each olItem In olFilterRecItems
        olItem.Delete
    Next olItem
    Set olRecItems = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
End Sub

Answer 1

Diane Poremsky has written a macro that goes through and removes cancelled appointments from the resource calender:

' A subroutine to remove cancelled appointments.
Sub RemoveCanceledAppointments()  

'Form variables.
Dim OutLookResourceCalendar As Outlook.MAPIFolder, OutLookAppointmentItem As Outlook.AppointmentItem, IntegerCounter As Integer 

'This sets the path to the resource calender.
Set OutLookResourceCalendar = OpenMAPIFolder("\MailboxName\Calendar")  
For IntegerCounter = OutLookResourceCalendar.Items.Count To 1 Step -1  

Set OutLookAppointmentItem = OutLookResourceCalendar.Items(IntegerCounter)  

    If Left(OutLookAppointmentItem.Subject, 9) = "Canceled:" Then 

        OutLookAppointmentItem.Delete  

    End If 

Next 

Set OutLookAppointmentItem = Nothing 

Set OutLookResourceCalendar = Nothing 

End Sub 

 ' A function for the folder path.
Function OpenMAPIFolder(FolderPathVar)  

Dim SelectedApplication, FolderNameSpace, SelectedFolder, FolderDirectoryVar, i  

Set SelectedFolder = Nothing 

Set SelectedApplication = CreateObject("Outlook.Application")  
If Left(FolderPathVar, Len("\")) = "\" Then 

    FolderPathVar = Mid(FolderPathVar, Len("\") + 1)  

Else 

    Set SelectedFolder = SelectedApplication.ActiveExplorer.CurrentFolder  

End If 

While FolderPathVar <> "" 

' Backslash var.
i = InStr(FolderPathVar, "\")  

        'If a Backslash is present, acquire the directory path and the folder path...[i].
        If i Then 

            FolderDirectoryVar = Left(FolderPathVar, i - 1)  

            FolderPathVar = Mid(FolderPathVar, i + Len("\"))  

        Else 

            '[i] ...or set the path to nothing.
            FolderDirectoryVar = FolderPathVar  

            FolderPathVar = "" 

        End If 

        ' Retrieves the folder name space from the Outlook namespace, unless a folder exists... [ii].
        If IsNothing(SelectedFolder) Then 

            Set FolderNameSpace = SelectedApplication.GetNamespace("MAPI")  

            Set SelectedFolder = FolderNameSpace.Folders(FolderDirectoryVar)  

        Else 

        ' [ii] in which case the the existing folder namespace is used.
            Set SelectedFolder = SelectedFolder.Folders(FolderDirectoryVar)  

        End If 

    Wend  

Set OpenMAPIFolder = SelectedFolder  

End Function 


 ' A function to check too see if there is no set namespace for the folder path.
Function IsNothing(Obj)  

If TypeName(Obj) = "Nothing" Then 

    IsNothing = True 

Else 

    IsNothing = False 

End If 

End Function 

Let me know if that removes the cancelled appointments from the resource calender –

~JOL