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