Dim WithEvents curCal As Items Dim WithEvents DeletedItems As Items Dim newCalFolder As Outlook.folder Private Sub Application_Startup() Dim NS As Outlook.NameSpace Set NS = Application.GetNamespace("MAPI") ' calendar to watch for new items Set curCal = NS.GetDefaultFolder(olFolderCalendar).Items ' watch deleted folder Set DeletedItems = NS.GetDefaultFolder(olFolderDeletedItems).Items ' calendar moving copy to Set newCalFolder = GetFolderPath("data-file-name\calendar") Set NS = Nothing End Sub Private Sub curCal_ItemAdd(ByVal Item As Object) Dim cAppt As AppointmentItem Dim moveCal As AppointmentItem ' On Error Resume Next 'remove to make a copy of all items If Item.BusyStatus = olBusy Then Item.Body = Item.Body & "[" & GetGUID & "]" Item.Save Set cAppt = Application.CreateItem(olAppointmentItem) With cAppt .Subject = "Copied: " & Item.Subject .Start = Item.Start .Duration = Item.Duration .Location = Item.Location .Body = Item.Body End With ' set the category after it's moved to force EAS to sync changes Set moveCal = cAppt.Move(newCalFolder) moveCal.Categories = "moved" moveCal.Save End If End Sub Private Sub curCal_ItemChange(ByVal Item As Object) Dim cAppt As AppointmentItem Dim objAppointment As AppointmentItem On Error Resume Next ' use 2 + the length of the GUID strBody = Right(Item.Body, 38) For Each objAppointment In newCalFolder.Items If InStr(1, objAppointment.Body, strBody) Then Set cAppt = objAppointment End If Next With cAppt .Subject = "Copied: " & Item.Subject .Start = Item.Start .Duration = Item.Duration .Location = Item.Location .Body = Item.Body .Save End With End Sub Private Sub DeletedItems_ItemAdd(ByVal Item As Object) ' only apply to appointments If Item.MessageClass <> "IPM.Appointment" Then Exit Sub ' if using a category on copied items, this may speed it up. If Item.Categories = "moved" Then Exit Sub Dim cAppt As AppointmentItem Dim objAppointment As AppointmentItem Dim strBody As String On Error Resume Next ' use 2 + the length of the GUID strBody = Right(Item.Body, 38) If Left(strBody, 1) <> "[" Then Exit Sub For Each objAppointment In newCalFolder.Items If InStr(1, objAppointment.Body, strBody) Then Set cAppt = objAppointment cAppt.Delete End If Next End Sub b Public Function GetGUID() As String GetGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36) End Function Function GetFolderPath(ByVal FolderPath As String) As Outlook.folder Dim oFolder As Outlook.folder Dim FoldersArray As Variant Dim i As Integer On Error GoTo GetFolderPath_Error If Left(FolderPath, 2) = "\\" Then FolderPath = Right(FolderPath, Len(FolderPath) - 2) End If 'Convert folderpath to array FoldersArray = Split(FolderPath, "\") Set oFolder = Application.Session.Folders.Item(FoldersArray(0)) If Not oFolder Is Nothing Then For i = 1 To UBound(FoldersArray, 1) Dim SubFolders As Outlook.Folders Set SubFolders = oFolder.Folders Set oFolder = SubFolders.Item(FoldersArray(i)) If oFolder Is Nothing Then Set GetFolderPath = Nothing End If Next End If 'Return the oFolder Set GetFolderPath = oFolder Exit Function GetFolderPath_Error: Set GetFolderPath = Nothing Exit Function End Function