Progrmatically created calendar items not showing up when others users look at calendar

[Scott Townsend]

We have a Website that we use to create meeting appointments. It populates a
SQL Database that then has an even that creates an item in that users
Calendar for the Appointment.

The user can then go into outlook and see the calendar Item.

If another user that has permissions to view their calendar looks to see if
they are busy does not see the Item that the SQL Server Created.

If the owner of the Appointment opens the Item, then clicks the save button,
the Item then shows up for the 3rd party user that wants to look at his
calendar.

Any leasts to the cause of the issue would be appreciated,

Thanks,
Scott<

Here is the Code we use to create the Appointments


OPTION EXPLICIT


'**********************************************************************
' Visual Basic Transformation Script
' For a description of codes to access appointment fields. Check out
http://www.cdolive.com/cdo10.htm
'************************************************************************

Const cStrServer = "<server IP Address>"
Const cStrMailbox ="<exchange-user-account>"
Const bdebug = 1

DIM fso, fname
DIM StrMailBox
DIM StrLastMailbox
DIM bstrProfileInfo

Dim objSession, objInfoStores, objInfoStore, objTopFolder, objFolders,
objFolder
Dim objMessages, objOneMessage, objAppt
Dim strStoreID

Function Start()
StrLastMailbox = ""
IF bdebug = 1 THEN
Set fso = CreateObject("Scripting.FileSystemObject")
Set fname = fso.CreateTextFile("c:\debugdts1.txt")
End if
Start = DTSTransformStat_OK
End Function

Function Endit()
If bdebug = 1Then
fname.Close
Set fname = Nothing
Set fso = Nothing
End If
Endit = DTSTransformStat_OK
End Function

Function Logoff()
Set objSession = Nothing
Set objInfoStores = Nothing
Set objInfoStore = Nothing
Set objTopFolder = Nothing
Set objFolder = Nothing
Set objFolders = Nothing
Set ObjMessages = Nothing
End Function

Function Logon()

Dim i

Logoff()

bstrProfileInfo = cStrServer & vbLf & StrMailbox

If bdebug = 1 then
fname.WriteLine("Logging on to email with profile : " + bstrProfileInfo)
End If

Set objSession = CreateObject("mapi.session")
objSession.Logon "", "", False, True, 0, True, bstrProfileInfo

Set objInfoStores = objSession.InfoStores

For i = 1 To objInfoStores.Count
If Left(objInfoStores.Item(i),10) = "Mailbox - " Then
Set objInfoStore=objInfoStores.Item(i)
Exit For
End If
Next

IF ISEMPTY(objInfoStore) THEN
Logon = DTSTransformStat_SkipRow
Exit Function
END IF

Set objTopFolder = objInfoStore.RootFolder
Set objFolders = objTopFolder.Folders
Set objFolder=objFolders.GetFirst()

Do Until objFolder.Name = "Calendar"
Set objFolder=objFolders.GetNext()
IF ISEMPTY(objFolder) or ISNULL(objFolder) THEN
Exit Do
END IF
Loop

IF ISEMPTY(objFolder) or ISNULL(objFolder) THEN
Logon = DTSTransformStat_SkipRow
Exit Function
END IF

strStoreID = objFolder.storeID
Set objMessages = objFolder.Messages

If bdebug = 1 Then
fname.WriteLine("All Logged On to Email")
End if

Logon = DTSTransformStat_OK

End Function

Function Main()

Dim strMessageID, strLastMailBox, strStoreID, strBodyText, strLocation
Dim dt_startdate, dt_enddate, dt_now
Dim i, ihours, iminutes
Dim return

StrMailBox = DTSSource("user_name")
IF StrMailBox <> StrLastMailBox THEN
return = Logon()
Main = return
IF return <> DTSTransformStat_OK Then
Exit Function
End if
StrLastMailBox = StrMailBox
END IF

dt_now = Date()

IF DTSSource("source_status") = "New" OR DTSSource("source_status") =
"Modified" THEN

strBodyText = "A Meeting has been scheduled with " +
DTSSource("contact_name") + " from " + DTSSource("customer_name") + vbCRLF +
VBCRLF
strBodyText = strBodyText + "Find it at :
http://site.domain.com/salescenter/updatetask.asp?ti="+
CSTR(DTSSource("task_id")) + " " + vbCRLF + vbCRLF
strBodyText = strBodyText + DTSSource("description") + vbCRLF + vbCRLF

IF DTSSource("source_status") = "New" THEN
Set objAppt = objMessages.Add
objAppt.Fields.Add &H30070040, dt_now ' Set Creation Time
StrBodyText = strBodyText + " (Added on "+ CSTR(Date()) + " " +
CSTR(Time()) +")"
ELSE
ON ERROR RESUME NEXT ' Disable Error Catching Due to Posible lookup to
find a message that doesn't exist
StrMessageID = DTSSource("outlook_ID")
Set objAppt = objSession.GetMessage(strMessageID, strStoreID)
' IF Err.Number = &H8004010F or Err.Number = &H80040107 THEN
IF Err.Number <> 0 THEN
Set objAppt = objMessages.Add
StrBodyText = strBodyText + " (ReAdded on "+CSTR( Date()) + " " +
CSTR(Time()) +")"
objAppt.Fields.Add &H30070040, dt_now ' Set Creation Time
ELSE
StrBodyText = strBodyText + " (Modified on "+ CSTR(Date()) + " " +
CSTR(Time()) +")"
END IF
ON ERROR GOTO 0 ' Enable Error Catching
END IF

objAppt.Type = "IPM.Appointment"
objAppt.Subject = "Meeting with " + DTSSource("contact_name") + "
("+DTSSource("customer_name")+")"
objAppt.Fields.Add &H1000001F, StrBodyText
objAppt.Fields.Add &H30080040, dt_now ' Set Modification Time

' Set Start Time and End time of Appointment

dt_startdate =CDATE(DTSSource("thedate"))
ihours = CDBL(DTSSource("duration"))
iminutes = ihours * 60
dt_enddate = DateAdd("N", iminutes , dt_startdate)

objAppt.Fields.Add "0x820D", vbDate, dt_startdate,
"0220060000000000C000000000000046"
objAppt.Fields.Add "0x820E", vbDate, dt_enddate,
"0220060000000000C000000000000046"

' Set Location Field to whatever description the user put in.
strLocation = DTSSource("location")
objAppt.Fields.Add "0x8208", vbString, strLocation ,
"0220060000000000C000000000000046"
objAppt.Update

DTSDestination("event_id") = DTSSource("event_id")
strMessageID = objAppt.ID
DTSDestination("outlook_ID") = strMessageID
DTSDestination("source_timestamp") =DTSSource("last_modified_date")

Main = DTSTransformstat_UpdateQuery

ELSEIF DTSSource("source_status") = "Deleted" THEN
DTSDestination("event_id") = DTSSource("event_id")
StrMessageID = DTSSource("outlook_ID")
ON ERROR RESUME NEXT
Set objAppt = objSession.GetMessage(strMessageID, strStoreID)
objAppt.Delete
ON ERROR GOTO 0
Main = DTSTransformStat_DeleteQuery
ELSE
Main = DTSTransformStat_SkipRow
END IF

Set objAppt = Nothing
Set objMessages = Nothing
Set ObjFolder = Nothing
Set objFolders = Nothing
Set objSession = Nothing
End Function

 

[Sue Mosher [MVP-Outlook]]

I think the problem is that the free/busy map is not updated unless a client
application such as Outlook or OWA makes a change to the calendar. Since
your code is using CDO to create the calendar items, the Outlook client is
never invoked to update the free/busy map.

 

[Scott Townsend]

hmm...

So what you are saying is that if I use CDO to create an Appointment, then
from another user's Outlook to View the Calendar of the CDO appointment that
was made, It might not be there.

Though if I log in as the user the CDO appointment was created for and just
look at my calendar, (or click tools, Send/Receive Free Busy Information)
then go to the other user's Outlook and try to see the appointments, they
will then show up?

If that is the case, is there a way to force the Free/Busy info to be
updated programmatically?

Thanks!

Scott<-