Appointment Time Rounding Issue

[GeoffG]

After creating an Appointment Item programmatically, Outlook 2002 fails to
identify the item when looping through the Items collection of the Calendar
folder. This happens when the Appointment is on the half hour, but it
doesn't happen when the Appointment in on the hour. Is there a precision or
rounding issue concerning times? What's the solution please?

You can copy and paste the code below into a Microsoft Access module to
demonstrate the problem. (You'll need a reference to Outlook.)

Geoff


Option Compare Database
Option Explicit

Private mobjOLA As Outlook.Application
Private mobjNS As Outlook.NameSpace
Private mobjFLDR As Outlook.MAPIFolder
Private mobjAPPT As Outlook.AppointmentItem

Private Sub DemoAppointmentTimeProblem()

' This subprocedure was run in Outlook 2002.

' This subprocedure appears to demonstrate that
' there may be a precision or rounding issue
' concerning Outlook Appointment times.
'
' Appointments created on the hour are located
' but Appointments created on the half hour are
' not located.
'
' Why should this be?
' What's the solution?


Dim datStart As Date
Dim datDate As Date
Dim datTime As Date
Dim I As Integer

Call InitialiseOutlook

' This does work!
' Note the time is set for on the hour.
datDate = DateSerial(2007, 3, 5)
datTime = TimeSerial(11, 0, 0)
datStart = datDate + datTime
I = I + 1
Call CreateAppointment(I, datStart)

' This doesn't work!
' Note the time is set for 30 minutes past the hour.
datDate = DateSerial(2007, 3, 5)
datTime = TimeSerial(11, 30, 0)
datStart = datDate + datTime
I = I + 1
Call CreateAppointment(I, datStart)

Call CleanUp

End Sub

Private Sub InitialiseOutlook()

Set mobjOLA = CreateObject("Outlook.Application")
Set mobjNS = mobjOLA.GetNamespace("MAPI")
mobjNS.Logon , , False, False
Set mobjFLDR = mobjNS.GetDefaultFolder(olFolderCalendar)

End Sub

Private Sub CreateAppointment( _
intTestNo As Integer, _
datStart As Date)

Dim strSubject As String
Dim fFound As Boolean
Dim strMessage As String
Dim intButtons As Integer
Dim strHeading As String

strSubject = "*** TIME TEST ***"

' Create Appointment Item:
Set mobjAPPT = mobjOLA.CreateItem(olAppointmentItem)
mobjAPPT.Start = datStart
mobjAPPT.Subject = strSubject
mobjAPPT.ReminderSet = False
mobjAPPT.Save

' Search for Appointment Item:
fFound = False
For Each mobjAPPT In mobjFLDR.Items
If mobjAPPT.Start = datStart And _
mobjAPPT.Subject = strSubject Then
fFound = True
Exit For
End If
Next

' Evaluate the fFound flag:
If fFound Then
GoTo AppointmentItemFound
Else
GoTo AppointmentItemNotFound
End If

Bye:

Exit Sub

AppointmentItemFound:

' Show Found message:
strMessage = "Subject:" & vbTab & strSubject _
& vbNewLine _
& "Original:" & vbTab & datStart _
& vbNewLine _
& "Current:" & vbTab & mobjAPPT.Start _
& vbNewLine & vbNewLine _
& "The above Appointment Item exists and was found." _
& vbNewLine _
& "VBA compared the above Original and Current " _
& "Date/Times and found them to be the same. " _
& vbNewLine _
& "(Note - Times on-the-hour work.)" & vbNewLine _
& "The Appointment Item will now be deleted."
intButtons = vbOKOnly Or vbInformation
strHeading = "TEST NUMBER " & CStr(intTestNo) _
& " - SUCCESS!"
MsgBox strMessage, intButtons, strHeading

' Delete the Appointment Item:
mobjAPPT.Delete

GoTo Bye

AppointmentItemNotFound:

' Point to the existing Appointment Item we created:
Set mobjAPPT = mobjFLDR.Items(strSubject)

' Show Not Found message:
strMessage = "Subject:" & vbTab & strSubject _
& vbNewLine _
& "Original:" & vbTab & datStart _
& vbNewLine _
& "Current:" & vbTab & mobjAPPT.Start _
& vbNewLine & vbNewLine _
& "The above Appointment Item exists but was " _
& "not found!" & vbNewLine _
& "VBA compared the above Original and Current " _
& "Date/Times and found them to be different," _
& vbNewLine _
& "even though they appear to be the same." _
& vbNewLine _
& "(Note - Times on-the-half-hour don't work.)" _
& vbNewLine _
& "The Appointment Item will now be deleted."
intButtons = vbOKOnly Or vbCritical
strHeading = "TEST NUMBER " & CStr(intTestNo) _
& " - FAILED!"
MsgBox strMessage, intButtons, strHeading

' Delete the Appointment Item:
mobjAPPT.Delete

GoTo Bye

End Sub

Private Sub CleanUp()

' Clean up:
Set mobjAPPT = Nothing
Set mobjFLDR = Nothing
Set mobjNS = Nothing
Set mobjOLA = Nothing

End Sub

 

[Dmitry Streblechenko]

Firstly, "Outlook 2002 fails to identify the item" is not exactly accurate -
it is your code that tries to identify the item.
Never ever use "=" when working with date/time values - always check against
a range of value (e.g. 11:29:59 to 11:30:01 in your case)

Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool

 

[GeoffG]

Very interesting. Thanks
Geoff