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"
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"