|
|
Outlook Calendar Sharing without Exchange Server
Hi,
I have written this code... to share the outlook calendar between two computer. The code simply copies the calendar data from one computer to an access database, which the other computer will use to load the appointments from and vice versa. I need someone out there to test the code, and suggest modifications, and the best way to run it without the end users knowledge. To test it, you need to paste the code to a .vbs file, set up a system DSN called "SharedAppointmentData" pointing to an access database with a table named "Appointments" which contains the fields "EntryID, StartDate, StartTime, EndDate, EndTime, Subject, Location, EntryID1". Any suggestion is appreciated. Best Regards, Shafiee. Here is the code: ------------------------------------------------- 'Initialize variables Dim olapp Dim amptitem Dim olAppointmentItem Dim olFolderCalendar Dim MAPINamespace Dim MAPIFolder Dim conAppointments Dim rstAppointments Dim strSQL olAppointmentItem = 1 olFolderCalendar = 9 on error resume next InitializeObjects Sub InitializeObjects() 'Gets the active instance of Outlook Set olapp = GetObject(, "Outlook.Application") 'Exits the procedure if outlook is not open if err.number 0 then exit sub end if Set conAppointments = CreateObject("ADODB.Connection") Set rstAppointments = CreateObject("ADODB.Recordset") With conAppointments ..connectionstring = "dsn=SharedAppointmentData" ..open End With With rstAppointments ..activeconnection = conAppointments ..LockType = 3 ..CursorType = 1 End With WriteOutgoingAppointments CreateIncomingAppointments End Sub 'CreateAppointment False, "23/8/2006", "15:00", "23/8/2006", "15:30", "Test appointment", "Test location" 'CheckOutgoingAppointments Sub WriteOutgoingAppointments() Set MAPINamespace = olapp.GetNamespace("MAPI") Set MAPIFolder = MAPINamespace.GetDefaultFolder(olFolderCalendar) for i = 1 to mapifolder.items.count strSQL = "SELECT * FROM Appointments WHERE EntryID = '" & mapifolder.items(i).EntryID & "'" with rstAppointments ..source = strSQL ..open end with if rstAppointments.RecordCount = 0 then with rstAppointments ..AddNew ..Fields("EntryID") = mapifolder.items(i).EntryID ..Fields("StartDate") = datevalue(mapifolder.items(i).Start) ..Fields("StartTime") = timevalue(mapifolder.items(i).Start) ..Fields("EndDate") = datevalue(mapifolder.items(i).End) ..Fields("EndTime") = timevalue(mapifolder.items(i).End) ..Fields("Subject") = mapifolder.items(i).Subject ..Fields("Location") = mapifolder.items(i).Location ..Update end with end if rstAppointments.Close next End Sub Sub CreateIncomingAppointments() With rstAppointments ..source = "SELECT * FROM Appointments" ..open End With rstAppointments.MoveFirst err.number = 0 For i = 1 to rstAppointments.RecordCount on error resume next MAPINamespace.GetItemFromID rstAppointments.Fields("EntryID").value if err.number 0 then err.number = 0 if isnull(rstAppointments.Fields("EntryID1").value) then rstAppointments.Fields("EntryID1").value = CreateAppointment(False, rstAppointments.Fields("StartDate"), rstAppointments.Fields("StartTime"), rstAppointments.Fields("EndDate"), rstAppointments.Fields("EndTime"), rstAppointments.Fields("Subject"), rstAppointments.Fields("Location")) rstAppointments.update end if end if rstAppointments.movenext Next rstAppointments.Close End Sub Function CreateAppointment(boolAllDayEvent, dtStart, tmStart, dtEnd, tmEnd, strSubject, strLocation) Set apmtitem = olapp.CreateItem(olAppointmentItem) With apmtitem ..AllDayEvent = boolAllDayEvent ..Start = DateValue(dtStart) + TimeValue(tmStart) ..End = DateValue(dtEnd) + TimeValue(tmEnd) ..Subject = strSubject ..Location = strLocation ..Save CreateAppointment = .EntryID End With End Function ------------------------------------ |
Outlook Calendar Sharing without Exchange Server
Very complicated - it is more easy to use add-inn (there are many of
them in the web), for example: http://shareo.4team.biz/?pcode=607180190pwkkd3 - allows to share not only Calendar, but other folders as well Try - really easy-to use tool :) Shafiee wrote: Hi, I have written this code... to share the outlook calendar between two computer. The code simply copies the calendar data from one computer to an access database, which the other computer will use to load the appointments from and vice versa. I need someone out there to test the code, and suggest modifications, and the best way to run it without the end users knowledge. To test it, you need to paste the code to a .vbs file, set up a system DSN called "SharedAppointmentData" pointing to an access database with a table named "Appointments" which contains the fields "EntryID, StartDate, StartTime, EndDate, EndTime, Subject, Location, EntryID1". Any suggestion is appreciated. Best Regards, Shafiee. Here is the code: ------------------------------------------------- 'Initialize variables Dim olapp Dim amptitem Dim olAppointmentItem Dim olFolderCalendar Dim MAPINamespace Dim MAPIFolder Dim conAppointments Dim rstAppointments Dim strSQL olAppointmentItem = 1 olFolderCalendar = 9 on error resume next InitializeObjects Sub InitializeObjects() 'Gets the active instance of Outlook Set olapp = GetObject(, "Outlook.Application") 'Exits the procedure if outlook is not open if err.number 0 then exit sub end if Set conAppointments = CreateObject("ADODB.Connection") Set rstAppointments = CreateObject("ADODB.Recordset") With conAppointments .connectionstring = "dsn=SharedAppointmentData" .open End With With rstAppointments .activeconnection = conAppointments .LockType = 3 .CursorType = 1 End With WriteOutgoingAppointments CreateIncomingAppointments End Sub 'CreateAppointment False, "23/8/2006", "15:00", "23/8/2006", "15:30", "Test appointment", "Test location" 'CheckOutgoingAppointments Sub WriteOutgoingAppointments() Set MAPINamespace = olapp.GetNamespace("MAPI") Set MAPIFolder = MAPINamespace.GetDefaultFolder(olFolderCalendar) for i = 1 to mapifolder.items.count strSQL = "SELECT * FROM Appointments WHERE EntryID = '" & mapifolder.items(i).EntryID & "'" with rstAppointments .source = strSQL .open end with if rstAppointments.RecordCount = 0 then with rstAppointments .AddNew .Fields("EntryID") = mapifolder.items(i).EntryID .Fields("StartDate") = datevalue(mapifolder.items(i).Start) .Fields("StartTime") = timevalue(mapifolder.items(i).Start) .Fields("EndDate") = datevalue(mapifolder.items(i).End) .Fields("EndTime") = timevalue(mapifolder.items(i).End) .Fields("Subject") = mapifolder.items(i).Subject .Fields("Location") = mapifolder.items(i).Location .Update end with end if rstAppointments.Close next End Sub Sub CreateIncomingAppointments() With rstAppointments .source = "SELECT * FROM Appointments" .open End With rstAppointments.MoveFirst err.number = 0 For i = 1 to rstAppointments.RecordCount on error resume next MAPINamespace.GetItemFromID rstAppointments.Fields("EntryID").value if err.number 0 then err.number = 0 if isnull(rstAppointments.Fields("EntryID1").value) then rstAppointments.Fields("EntryID1").value = CreateAppointment(False, rstAppointments.Fields("StartDate"), rstAppointments.Fields("StartTime"), rstAppointments.Fields("EndDate"), rstAppointments.Fields("EndTime"), rstAppointments.Fields("Subject"), rstAppointments.Fields("Location")) rstAppointments.update end if end if rstAppointments.movenext Next rstAppointments.Close End Sub Function CreateAppointment(boolAllDayEvent, dtStart, tmStart, dtEnd, tmEnd, strSubject, strLocation) Set apmtitem = olapp.CreateItem(olAppointmentItem) With apmtitem .AllDayEvent = boolAllDayEvent .Start = DateValue(dtStart) + TimeValue(tmStart) .End = DateValue(dtEnd) + TimeValue(tmEnd) .Subject = strSubject .Location = strLocation .Save CreateAppointment = .EntryID End With End Function ------------------------------------ |
| All times are GMT +1. The time now is 03:48 PM. |
Powered by vBulletin® Version 3.6.4
Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
Search Engine Friendly URLs by vBSEO 2.4.0
Copyright ©2004-2006 OutlookBanter.com