DELETING ORPHANED RECORDS

[Dave Hopper]

Hi

I have sucessfully managed to write code to add, delete and import
amended appointment items into an MS Access database.

I am having a problem with one last issue and despite searching the
newgroups, outlookcode.com, slipstick.com and CDOLive, I don't seem to
be able to resolve it.

My problem is with my importing amended appointment items, it works
fine until a user deletes an appointment directly using outlook, then
it fails with an object variable not set error. What I need to be
able to do is delete the corresponding missing record in my access
table (tblappointments) based on this failure. This should in theory
be easy as I store a unique ID in the mileage field of each
appointment when it's created.

My problem is my lack of knowledge, I'm a newbie to VBA and simply
haven't been able to work out the syntax (despite having spent three
days on it!).

I really would appreciate ANY help at all in working this issue
through.

I have attached my import code below for reference

Public Function ImportAppointments()

Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("tblAppointments")

Dim Prop As Outlook.UserProperty

Dim objOL As New Outlook.Application
Dim objNS As Outlook.NameSpace
Dim strFind As String
Dim objCalFolder As Outlook.MAPIFolder
Dim AllPublicFolders As Outlook.MAPIFolder
Dim MyPublicFolder As Outlook.MAPIFolder
Dim colCalendar As Outlook.Items
Dim objAppt As Outlook.AppointmentItem

Dim db As Database
Dim rsAppointmentsRecords As Recordset
Dim str As String
Dim TableName As String

Set db = CurrentDb

Dim myOlApp
Dim mNameSpace

Dim MyItem
Dim strMsg

Dim strPublicFolder
Dim strSubject
Dim strStart
Dim strEnd
Dim strBody
Dim strLocation
Dim strRequiredAttendees
Dim strCategories
Dim strBillingInformation
Dim strShow
Dim strUniqueID

Const olAppointmentItem = 1

strPublicFolder = ("Office")

If Len(strPublicFolder) > 0 Then

Set objOL = CreateObject("Outlook.Application")
Set mNameSpace = objOL.GetNamespace("MAPI")
Set objCalFolder = mNameSpace.Folders("Public Folders")
Set AllPublicFolders = objCalFolder.Folders("All Public Folders")
Set MyPublicFolder = AllPublicFolders.Folders("Office")
Set colCalendar = MyPublicFolder.Items

strFind = "[Mileage] = " & Forms!testform!UniqueID & ""
strShow = "" & Forms!testform!UniqueID & ""

Set objAppt = colCalendar.Find(strFind)

Set rst = CurrentDb.OpenRecordset("tblAppointments")



rst.MoveLast
rst.MoveFirst

Do Until rst.EOF

If rst(0) = strShow Then

With objAppt

strLocation = .Location
strSubject = .Subject
strStart = .Start
strBody = .Body

End With

str = "UPDATE tblAppointments SET tblAppointments.ApptLocation = '" &
strLocation & "'WHERE tblAppointments.UniqueID = '" & strShow & "'"
DoCmd.RunSQL (str)
Debug.Print str
str = "UPDATE tblAppointments SET tblAppointments.Appt = '" &
strSubject & "'WHERE tblAppointments.UniqueID = '" & strShow & "'"
DoCmd.RunSQL (str)
Debug.Print str
str = "UPDATE tblAppointments SET tblAppointments.ApptStartDate = '" &
strStart & "'WHERE tblAppointments.UniqueID = '" & strShow & "'"
DoCmd.RunSQL (str)
Debug.Print str
str = "UPDATE tblAppointments SET tblAppointments.ApptNotes = '" &
strBody & "'WHERE tblAppointments.UniqueID = '" & strShow & "'"
DoCmd.RunSQL (str)
Debug.Print str

End If

rst.MoveNext

Loop

rst.Close

db.Close

Set objOL = Nothing
Set objNS = Nothing
Set objCalFolder = Nothing
Set colCalendar = Nothing
End If

End Function