Deleting Appointments from Outlook (1 Viewer)

jbenner

Registered User.
Local time
Today, 15:40
Joined
Mar 8, 2013
Messages
11
Hi there,
I have a database that I schedule various appointments in and have built a button to add those appointments to my MS Outlook Calendar using VBA code. I have also built some code to delete the appointments if I need to. The code works... but it works very slowly. I think it's because it is trying to evaluate EVERY appointment in my calendar to see if the criteria matches. (I have flagged the problem line below in pink) Is there some way to modify this code to only look at Outlook Appointments within the desired date range?

Dim MyDB As Database
Dim MyRS As Recordset
Dim qdf As QueryDef
Dim frm As Form
Dim objOlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim objAppointment As Outlook.AppointmentItem
Dim objOAppt As Outlook.Items
Dim lngDeletedAppointements As Long

Set MyDB = CurrentDb
Set frm = Forms!frmMenScheduling
Set qdf = MyDB.QueryDefs("qryScXDate_OL")

'Enter the Query Parameters
qdf.Parameters("Forms!frmMenScheduling!SMStart") = frm.SMStart
qdf.Parameters("Forms!frmMenScheduling!SMEnd") = frm.SMEnd

'Open the Recordset Object
Set MyRS = qdf.OpenRecordset()
MyRS.MoveFirst

'Create the Outlook Session
Set objOlook = CreateObject("Outlook.Application")
Set objNamespace = objOlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)

Do Until MyRS.EOF
For Each objAppointment In objFolder.Items
If objAppointment.Mileage = MyRS!ApID Then
objAppointment.Delete
lngDeletedAppointements = lngDeletedAppointements + 1
End If
Next
MyRS.MoveNext
Loop
MsgBox lngDeletedAppointements & " Appointment(s) DELETED.", vbInformation, "DELETE Appointments"
 

arnelgp

..forever waiting... waiting for jellybean!
Local time
Tomorrow, 05:40
Joined
May 7, 2009
Messages
19,227
note i inserted another object in the code:

...
...
Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
Dim olfolder As Object
Set olfolder = objOutlook.GetNamespace("MAPI").PickFolder
Do Until MyRS.EOF
For Each objAppointment In olfolder.Items
...
...
 

jbenner

Registered User.
Local time
Today, 15:40
Joined
Mar 8, 2013
Messages
11
Thanks for the response arnelgp - I attempted to add that into my code but it doesn't seem to like the PickFolder line. I get the error message 424 - Object Required.
 

Cronk

Registered User.
Local time
Tomorrow, 07:40
Joined
Jul 4, 2013
Messages
2,771
Your code runs slowly because for every appointment, you are having to loop through every record in your recordset testing for equality.

I'd use Access to find any match ie
MyRS.findFirst "ApID=" & objAppointment.Mileage
if not MyRS.noMatch then objAppointment.delete

PS it will be faster if the field ApID is indexed

BTW I don't understand how mileage relates to a date range
 

jbenner

Registered User.
Local time
Today, 15:40
Joined
Mar 8, 2013
Messages
11
Hi Cronk, thanks for that I will try it out. Mileage is a hidden option in the MS Outlook Calendar. When I add the appointments to Outlook I use that field to store the Primary Key (ApID). As it is a number field it's perfect for storing my long integers. My end users don't see it, and therefore can't alter it, so I don't have to worry about broken links or altered Primary Keys. Therefore it's safe to use to retrieve the appointment for deleting. Cheers.
 

Users who are viewing this thread

Top Bottom