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!

 

[wigi]

Try this untested code:

Public Function DeleteAppointments(ByVal subjectStr As String)

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

    Set oAppointments = oOL.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
    
    For i = oAppointments.Items.Count To 1 Step -1
        Set oAppointmentItem = oAppointments(i)
        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
        End If
    Next

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

End Function

Please do not forget to use

 tags here. Thanks.

 

[PTurner]

Ok thanks for trying!

 

[wigi]

Ok thanks for trying!

Did you see my code above?

 

[xzw1222222]

I try to use your code and updated somewhere to based on my needs, but i have a new question: I can not delete all the appointments at one time, I need to run several times and then the appointments can be deleted. I have no idea about that, would you please help me? Very thanks.

Details as below:

Sub DeleteAppointments()
Dim oApp As Outlook.Application
Dim oNameSpaceAs Outlook.Namespace
Dim oApptItem As Outlook.AppointmentItem
Dim oFolder As Outlook.MAPIFolder
Dim oMeetingoApptItem As Outlook.MeetingItem
Dim oObject As Object
Dim sErrorMessage As String
Dim iRow, iCount As Long

Dim Dic As Object, I As Long, Ar, Br
Set Dic = CreateObject("scripting.dictionary")

Worksheets("sheet1").Select
Ar = Range([A8], [A1048576].End(3))

For I = 1 To UBound(Ar)
Dic(Trim(Ar(I, 1))) = ""
Next

iRow = Worksheets("Sheet1").Range("A1048576").End(xlUp).Row

On Error Resume Next
Set oApp = GetObject("Outlook.Application")
If Err <> 0 Then
Set oApp = CreateObject("Outlook.Application")
End If

On Error GoTo Err_Handler
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetDefaultFolder(9)

For Each oObject In oFolder.Items

Set oApptItem = oObject

Ar = oApptItem.Subject

If Dic.exists(Ar) Then
oApptItem.delete
iCount = iCount + 1
End If

Next oObject

Set oApp = Nothing
Set oNameSpace = Nothing
Set oApptItem = Nothing
Set oFolder = Nothing
Set oObject = Nothing

MsgBox "deleted " & iCount & " this time." & Chr(10) & Chr(10) & "Should Deleted " & iRow - 7 & " appointments." & Chr(10) & Chr(10) & "Have a nice day!", , "Just to let you know..."

Exit Sub


Err_Handler:
sErrorMessage = Err.Number & " " & Err.Description

End Sub

 

[s.ridd]

I'm unable to test your code but you could rewrite your code so instead of

[COLOR=#574123]For Each oObject In oFolder.Items[/COLOR]

you could use something like

[COLOR=#574123]For Each oObject In oFolder.Items.Restrict([Subject] = "etc")[/COLOR]

and then just delete each item in the collection

Hope this helps

Simon

 

[WahWahWeeks]

Thanks for this nice clear code.
At last I can do what I've been trying for two weeks

 

[Superman2283]

Good afternoon! I have cobbled together some code using what has been available (I don't take ownership of any of it), but I'm having difficulty getting it to delete a calendar appointment.

I'm tracking due dates, and I am able to create the appointments in outlook, via excel. I'm having difficulty in writing code that will delete the created calendar item if a deadline is met.

Any suggestions?

Dim row As Integer
Dim appointment As Boolean
Public Sub CreateBankStatementCalendar()
row = Selection.row
appointment = AddToCalendar(Cells(row, 7), "Bank Statement Due for " & ThisWorkbook.Sheets("Sheet1").Range("A1"), "", #12:00:00 PM#, #12:30:00 PM#)
'appointment = AddToCalendar(Cells(row, 8), "1st Files to Send", "Office2", #8:00:00 AM#, #9:00:00 AM#)
'If IsDate(Cells(row, 28)) Then appointment = AddToCalendar(Cells(row, 9), "Arrange Monitors", "Office3", #9:00:00 AM#, #10:00:00 AM#)
'If IsDate(Cells(row, 29)) Then appointment = AddToCalendar(Cells(row, 8), "Confirm Monitors", "Office4", #9:00:00 AM#, #10:00:00 AM#)
'If IsDate(Cells(row, 29)) Then appointment = AddToCalendar(Cells(row, 9), "DDS", "Office5", #10:00:00 AM#, #11:00:00 AM#)
'If Cells(row, 20) > 0 Then appointment = AddToCalendar(Cells(row, 21), "3rd Party letters to Send", "Office6", #10:00:00 AM#, #11:00:00 AM#)
End Sub

Function AddToCalendar(dteDate As Date, strSubject As String, strLoc As String, dteStart As Date, dteEnd As Date) As Boolean
On Error GoTo ErrorHandler
'--------------------------------------------------
'CREATE AND SET VARIABLES
Dim olApp As Object
Dim objNewAppt As Object
Set olApp = GetOutlookApplication
If olApp Is Nothing Then
MsgBox "Cannot access Outlook. Exiting now", vbInformation
GoTo ErrorHandler
End If
'--------------------------------------------------
'CREATE APPOINTMENT
Set objNewAppt = olApp.createitem(1) ' 1 is the constant for olAppointmentItem when using late-bound code, or VBScript
body = "Deadline to turn in bank statement for " & ThisWorkbook.Sheets("Sheet1").Range("A1") & Chr(13) & "Bank Statement dates: " & Cells(row, 2) & _
Chr(13) & "Due back to Program Manager by " & Cells(row, 7) 'body of message
With objNewAppt
.meetingstatus = 1
.Start = dteDate & " " & dteStart
.End = dteDate & " " & dteEnd
.Subject = strSubject
.Location = strLoc
.body = body
.reminderset = True
.ReminderMinutesBeforeStart = 30
.Recipients.Add ThisWorkbook.Sheets("Email Addresses").Range("a2")
.Recipients.Add ThisWorkbook.Sheets("Email Addresses").Range("a3")
.Recipients.Add ThisWorkbook.Sheets("Email Addresses").Range("a4")

.Recipients.resolveall
.Save
.send
End With
AddToCalendar = True
GoTo ExitProc
ErrorHandler:
AddToCalendar = False
MsgBox "Please make sure that the dates are in the correct format and" & Chr(13) & _
"you have selected a cell in the project row you wish to create tasks for."
ExitProc:
Set olApp = Nothing
Set objNewAppt = Nothing
End Function

Function GetOutlookApplication()
On Error Resume Next
Set GetOutlookApplication = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set GetOutlookApplication = CreateObject("Outlook.Application")
End If
On Error GoTo 0
End Function