How do I delete an Outlook appointment item with VBA?

[Joe Patrick]

From an excel workbook, I'd like to be able to find an outlook appointment item with subject containing a specified string and delete it.

I've searched but can't find anything that actually works.

Does someone have code for this? Thanx!

 

[John_w]

Try some of the code in http://www.mrexcel.com/forum/showthread.php?t=470308. It doesn't delete an Outlook appointment, but does create or update one, and uses the Restrict method to filter appointments by subject - or you could loop through calendar items looking for the specified string within the Subject.

 

[Ruddles]

Something like this should do the job. Paste this into a new standard code module, add a reference to the Microsoft Outlook Object Library, and off you go!

[FONT=Fixedsys]Option Explicit[/FONT]
[FONT=Fixedsys]Option Compare Text[/FONT]
 
[FONT=Fixedsys]Public Sub Driver()[/FONT]
[FONT=Fixedsys] Call DeleteAppointments("wibble")[/FONT]
[FONT=Fixedsys]End Sub[/FONT]
 
[FONT=Fixedsys]Public Sub DeleteAppointments(ByVal argSubject As String)[/FONT]
 
[FONT=Fixedsys] Dim oApp As Outlook.Application[/FONT]
[FONT=Fixedsys] Dim oNameSpace As Outlook.Namespace[/FONT]
[FONT=Fixedsys] Dim oApptItem As Outlook.AppointmentItem[/FONT]
[FONT=Fixedsys] Dim oFolder As Outlook.MAPIFolder[/FONT]
[FONT=Fixedsys] Dim oMeetingoApptItem As Outlook.MeetingItem[/FONT]
[FONT=Fixedsys] Dim oObject As Object[/FONT]
[FONT=Fixedsys] Dim iUserReply As VbMsgBoxResult[/FONT]
[FONT=Fixedsys] Dim sErrorMessage As String[/FONT]
 
[FONT=Fixedsys] On Error Resume Next[/FONT]
[FONT=Fixedsys] ' check if Outlook is running[/FONT]
[FONT=Fixedsys] Set oApp = GetObject("Outlook.Application")[/FONT]
[FONT=Fixedsys] If Err <> 0 Then[/FONT]
[FONT=Fixedsys]   'if not running, start it[/FONT]
[FONT=Fixedsys]   Set oApp = CreateObject("Outlook.Application")[/FONT]
[FONT=Fixedsys] End If[/FONT]
 
[FONT=Fixedsys] On Error GoTo Err_Handler[/FONT]
[FONT=Fixedsys] Set oNameSpace = oApp.GetNamespace("MAPI")[/FONT]
[FONT=Fixedsys] Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)[/FONT]
 
[FONT=Fixedsys] For Each oObject In oFolder.Items[/FONT]
[FONT=Fixedsys]   If oObject.Class = olAppointment Then[/FONT]
[FONT=Fixedsys]     Set oApptItem = oObject[/FONT]
[FONT=Fixedsys]     If InStr(oApptItem.Subject, argSubject) > 0 Then[/FONT]
[FONT=Fixedsys][COLOR=blue]       iUserReply = MsgBox("Appointment found:-" & vbCrLf & vbCrLf _[/COLOR][/FONT]
[FONT=Fixedsys][COLOR=blue]            & Space(4) & "Date/time: " & Format(oApptItem.Start, "dd/mm/yyyy hh:nn") _[/COLOR][/FONT]
[FONT=Fixedsys][COLOR=blue]            & " (" & oApptItem.Duration & "mins)" & Space(10) & vbCrLf _[/COLOR][/FONT]
[FONT=Fixedsys][COLOR=blue]            & Space(4) & "Subject: " & oApptItem.Subject & Space(10) & vbCrLf _[/COLOR][/FONT]
[FONT=Fixedsys][COLOR=blue]            & Space(4) & "Location: " & oApptItem.Location & Space(10) & vbCrLf & vbCrLf _[/COLOR][/FONT]
[FONT=Fixedsys][COLOR=blue]            & "Delete this appointment?", vbYesNo + vbQuestion + vbDefaultButton2, "Delete Appointment?")[/COLOR][/FONT]
[FONT=Fixedsys][COLOR=blue]       If iUserReply = vbYes Then[/COLOR] oApptItem.Delete[/FONT]
[FONT=Fixedsys]     End If[/FONT]
[FONT=Fixedsys]   End If[/FONT]
[FONT=Fixedsys] Next oObject[/FONT]
 
[FONT=Fixedsys] Set oApp = Nothing[/FONT]
[FONT=Fixedsys] Set oNameSpace = Nothing[/FONT]
[FONT=Fixedsys] Set oApptItem = Nothing[/FONT]
[FONT=Fixedsys] Set oFolder = Nothing[/FONT]
[FONT=Fixedsys] Set oObject = Nothing[/FONT]
 
[FONT=Fixedsys] Exit Sub[/FONT]
 
[FONT=Fixedsys]Err_Handler:[/FONT]
[FONT=Fixedsys] sErrorMessage = Err.Number & " " & Err.Description[/FONT]
 
[FONT=Fixedsys]End Sub[/FONT]

Notes: search is not case sensitive. To make it case-sensitive, change Option Compare Text to Option Compare Binary. You will be prompted as each appointment is found. Remove the code in blue if you don't want this prompt.

Shout if you have any problems.

 

[Joe Patrick]

John & Ruddles, thank you both for replying!

John, I couldn't get yours to work for me but, Ruddles' works perfectly.

Have a great weekend!

 

[Ruddles]

Thanks for the feedback.

Obviously, where you use InStr to test the subject, you can extend that to check any property or combination of properties of the Appointment item such as .Start (start date), .Duration, .Location, etc.

If you type oApptItem. into an empty line in your VBA module, you should get an IntelliSense drop-down listing all the properties you can check - the finger-pointy things. The flying green brick things are 'methods' which allow you to manipulate the Appointment items - .Copy, .Delete, etc.

 

[Joe Patrick]

Thank you so much, Ruddles! That will definitely come in handly!

 

[PTurner]

Hi there, I have implemented the for each construct to search for appointment items begining with a particular subject string. If found, I give the user the option to delete it and it successfully deletes the item. However, I find that not all items are found sometimes (depending on the order of items added). I presume after the deletion the item count is reduced and the "for each" construct stops before reaching the end of the items. If I rerun the deletion module it will pick up the one it missed. Is it possible to iterate through the appointments using something like an indexed array (0-Count)? Any suggestions would be appreciated.
Thanks

 

[Joe Patrick]

Hi, PTurner!

Please post your code and I'll take a look. I'm by no means an expert so no promises. I have an idea though.

 

[PTurner]

Here goes!

Public Function DeleteAppointments(ByVal subjectStr As String)

Dim oOL As New Outlook.Application
Dim oNS As Outlook.NameSpace
Dim oAppointments As Object
Dim oAppointmentItem As Outlook.AppointmentItem
Dim iReply As VbMsgBoxResult

Set oNS = oOL.GetNamespace("MAPI")
Set oAppointments = oNS.GetDefaultFolder(olFolderCalendar)
Count = oAppointments.Items.Count 'for test purposes

For Each oAppointmentItem In oAppointments.Items
If InStr(oAppointmentItem.Subject, subjectStr) > 0 Then
iReply = msgbox("Appointment found:" & vbCrLf & vbCrLf _
& Space(4) & "Date/time: " & Format(oAppointmentItem.Start, "dd/mm/yyyy hh:nn") & vbCrLf _
& Space(4) & "Subject: " & oAppointmentItem.Subject & Space(10) & vbCrLf & vbCrLf _
& "Delete this appointment?", vbYesNo + vbQuestion + vbDefaultButton2, "Delete Appointment?")
If iReply = vbYes Then oAppointmentItem.Delete
oAppointmentItem.Delete
End If
Next

Set oAppointmentItem = Nothing
Set oAppointments = Nothing
Set oNS = Nothing
Set oOL = Nothing

End Function

 

[Joe Patrick]

Sorry, my idea does not work. Hopefully someone else here can help you!