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

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

Thank you Julia....

The software you have recommended really worth attention.... I also
have tried ShareCalendar.... I think we will be purchasing it... It is
cheaper... You can find out more he
http://sharecalendar.4team.biz/?pcode=6083101948f43tk

raše:
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
------------------------------------