Outlook Appointment VBA Issues

[bluesbrthr]

I am writing a routine that will Outlook Appointment items and write
them into a database. When an item is recorded, I write the ID
created in Access into a custom field in the appointment item. This
is kinda working, but there are some strange issues.

I have 22 items in the Calendar. My filter is looking for the past 10
days and the next 10 days, so there will be additional items based on
recurrence. On the last run I did, 28 items were created.

#1 - When I view the custom field in Outlook, only 3 of the 22 items
show the ID that I wrote, yet on a second run where I check to see if
the items have an ID, they do. Why then, are they not showing?

#2 - When I run this a second time, 3 items are added again. These
are not the same items from issue #1

As for why we are doing it this way rather than just linking to the
calendar items, The user also needs to view the data while offline.

Thank you.


Public Function ImportCalendar_TEST()

'Access Calendar items (Past 10 days, Next 10 days
'Add Access-Created Calendar ID
'If Calendar ID field has a value, compare CORE fields values on
ietsm with matching ID, date, & time
'''If changes then save make a copy of existing values, save new
values
'''If No ID, add record; record Access ID in Calendar

'OUTLOOK
Dim objFPRecip As Outlook.Recipient
Dim SafeAppointment, oAppointment
Dim olOutlook As Outlook.Application
Dim nsNameSpace As NameSpace
Dim mItemCollection As Items
Dim myItems As Items

'ACCESS
Dim dbMain As DAO.Database
Dim rsAppointment As DAO.Recordset

'OTHER
Dim sFilter As String
Dim lAppID As Long

sFilter = "[End] >= '" & Format(Date - 10, "yyyy/mm/dd") & "' AND
[Start] <= '" & Format(Date + 10 & " 11:59 PM", "yyyy/mm/dd hh:nn") &
"'"

'LOCAL
Set olOutlook = CreateObject("Outlook.Application")
Set nsNameSpace = olOutlook.GetNamespace("MAPI")
Set myItems = nsNameSpace.GetDefaultFolder(olFolderCalendar).Items

myItems.Sort "[Start]", False
myItems.IncludeRecurrences = True

Set mItemCollection = myItems.Restrict(sFilter)

Set dbMain = CurrentDb

' LOOP OF CALENDAR ITEMS
*********************************************************************************************
For Each Item In mItemCollection
'APPOINTMENT CHECK
If Item.Class = olAppointment Then

Set SafeAppointment =
CreateObject("Redemption.SafeAppointmentItem")

Set oAppointment = Item
SafeAppointment.Item = oAppointment

If Not IsNumeric(SafeAppointment.UserProperties.Find("APPID")) Then
'Appointment was never added. Add Appointment to Database

SafeAppointment.UserProperties.Add "APPID", olText, True

Set rsAppointment = dbMain.OpenRecordset("SELECT * FROM
Appointment_TBL;")
rsAppointment.AddNew
rsAppointment("EntryID") = SafeAppointment.EntryID
rsAppointment.Fields("Start") = SafeAppointment.Start
rsAppointment.Fields("StartDate") = Format(SafeAppointment.Start,
"mm-dd-yyyy")
rsAppointment.Fields("StartTime") = Format(SafeAppointment.Start,
"hh:nn ampm")
rsAppointment.Fields("End") = SafeAppointment.End
rsAppointment.Fields("EndDate") = Format(SafeAppointment.End, "mm/
dd/yyyy")
rsAppointment.Fields("EndTime") = Format(SafeAppointment.End,
"hh:nn AMPM")
rsAppointment("ConversationTopic") =
SafeAppointment.ConversationTopic
rsAppointment("Subject") = SafeAppointment.Subject
rsAppointment("Body") = SafeAppointment.Body

'Add Access ID to Outlook
SafeAppointment.UserProperties.Find("APPID") =
rsAppointment("Appointment_ID")
SafeAppointment.Save

rsAppointment.Update
Set rsAppointment = Nothing
Debug.Print SafeAppointment.UserProperties.Find("APPID") & ":
Created"

Else
Debug.Print SafeAppointment.UserProperties.Find("APPID") & ":
Already Exists"
End If

Set SafeAppointment = Nothing

End If
Next
' END LOOP
****************************************************************************************************
End Function