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