Hi
I have some code that copies an appointment from one calendar to a public
calendar and it works fine when I’m using 2002. When I’m using 2003 and have
disabled macros, it also works fine but if I enable my macro I will miss
about 5 % of all updates in my own calendar and about 10 % in the public
calendar. I’m not running my macro in a class module. Could that be the
reason for missing updates? If so, how much of the macro should be in the
class module?

Thanks.
Attached you will find the coding

Option Explicit
Dim myOlApp As New Outlook.Application
Public WithEvents CalendarItems As Outlook.Items
Public WithEvents DeletedItems As Outlook.Items
Public TOCFolder As Outlook.MAPIFolder
Public sUser As String

Public Sub Initialize_handler()
sUser = "BOH "
Set CalendarItems = myOlApp.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderCalendar).Items
Set DeletedItems = myOlApp.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderDeletedItems).Items
Set TOCFolder = GetFolder("Public Folders\All Public Folders…….")
If TOCFolder Is Nothing Then
Set TOCFolder = GetFolder("………………")
End If
End Sub

Private Sub Application_Startup()
Initialize_handler
End Sub

Private Sub DeletedItems_Itemadd(ByVal Item As Object)
Dim OCalItem As Outlook.AppointmentItem
Dim OStr As String
On Error Resume Next
'MsgBox ("ItemDel")
If TOCFolder Is Nothing Then
MsgBox "Can´t get the folder TOC"
Else
OStr = "[Item]='" & Item & "'"
'MsgBox OStr
Set OCalItem = TOCFolder.Items.Find("[BillingInformation]='" &
Item.BillingInformation & "'")
If TypeName(OCalItem) "Nothing" Then
OCalItem.Delete
End If
End If
Set OCalItem = Nothing
End Sub

Private Sub CalendarItems_Itemadd(ByVal Item As Object)
Dim myAppt As Outlook.AppointmentItem
Dim myStr As String
On Error Resume Next
'MsgBox ("ItemAdd")
Item.BillingInformation = Item.LastModificationTime
Item.Save
Set myAppt = TOCFolder.Items.Add(Outlook.OlItemType.olAppointme ntItem)
myAppt = Item
myAppt.Duration = Item.Duration
myAppt.Sensitivity = Item.Sensitivity
If TOCFolder Is Nothing Then
MsgBox "Can´t get the folder TOC"
Else
If myAppt.Class olAppointment Then
' MsgBox myAppt.Class
' ElseIf myAppt.Sensitivity = olPrivate Then
ElseIf myAppt.Duration = 240 Then
Set myAppt = Nothing
Set myAppt = Item.Copy
If myAppt.Sensitivity olPrivate Then
myAppt.Subject = sUser & Item.Subject
Else
myAppt.Subject = sUser & "Privat"
myAppt.Location = ""
End If
myAppt.ReminderSet = False
myAppt.Move TOCFolder
End If
End If
Set myAppt = Nothing
End Sub

Private Sub CalendarItems_Itemchange(ByVal Item As Object)
Dim mychgAppt As Outlook.AppointmentItem
Dim OCalItem As Outlook.AppointmentItem
Dim OStr As String
On Error Resume Next
'MsgBox ("ItemChange")
If TOCFolder Is Nothing Then
MsgBox "Can´t get the folder TOC"
Else
OStr = "[Item]='" & Item & "'"
'MsgBox OStr
Set OCalItem = TOCFolder.Items.Find("[BillingInformation]='" &
Item.BillingInformation & "'")
If TypeName(OCalItem) "Nothing" Then
OCalItem.Delete
End If
Set mychgAppt = TOCFolder.Items.Add(Outlook.OlItemType.olAppointme ntItem)
mychgAppt = Item
mychgAppt.Duration = Item.Duration
mychgAppt.Sensitivity = Item.Sensitivity
If mychgAppt.Class olAppointment Then
' ElseIf mychgAppt.Sensitivity = olPrivate Then
' Set mychgAppt = Nothing
ElseIf mychgAppt.Duration = 240 Then
Set mychgAppt = Nothing
Set mychgAppt = Item.Copy
If mychgAppt.Sensitivity olPrivate Then
mychgAppt.Subject = sUser & Item.Subject
Else
mychgAppt.Subject = sUser & "Privat"
mychgAppt.Location = ""
End If
mychgAppt.ReminderSet = False
mychgAppt.Move TOCFolder
' MsgBox "Delete"
End If
Set mychgAppt = Nothing
End If
Set mychgAppt = Nothing
Set OCalItem = Nothing
End Sub