'event statements Private objNS As Outlook.NameSpace Private WithEvents objconvitems As Outlook.Items Private WithEvents sentMailItems As Items Private WithEvents objExplorer As Outlook.Explorer Private WithEvents objInspectors As Outlook.Inspectors Private WithEvents objMail As Outlook.MailItem Dim WithEvents curCal As Items Dim WithEvents curCal2 As Items Dim WithEvents DeletedItems As Items Dim newCalFolder As Outlook.folder Dim mainCalFolder As Outlook.folder 'Option Explicit '-----code below is to set the current folders to watch for upon withevents items being triggered Private Sub Application_Startup() Call HideFolders Call Initialize_handler End Sub Public Sub Initialize_handler() '---Mail item code Set sentMailItems = Session.GetDefaultFolder(olFolderSentMail).Items Set objExplorer = Outlook.Application.ActiveExplorer Set objInspectors = Outlook.Application.Inspectors '---converstaion history Dim objwatchfolder As Outlook.folder 'Set conversationhistoryItems = Session.GetDefaultFolder("Conversation History").Items 'Set conversationhistoryItems = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Conversation History").Items Set objNS = Application.GetNamespace("MAPI") Set objwatchfolder = objNS.GetDefaultFolder(olFolderInbox).Parent.Folders("Conversation History") Set objconvitems = objwatchfolder.Items '---meetign copy code below to end sub Dim NS As Outlook.NameSpace Set NS = Application.GetNamespace("MAPI") ' calendar to watch for new items Set curCal = NS.GetDefaultFolder(olFolderCalendar).Items ' calendar main to watch for changes Set curCal2 = NS.GetDefaultFolder(olFolderCalendar).Folders("DL Meeting Backup History").Items ' watch deleted folder Set DeletedItems = NS.GetDefaultFolder(olFolderDeletedItems).Items ' calendar moving copy to Set newCalFolder = GetFolderPath("\\david.lane@fraserhealth.ca\Calendar\DL Meeting Backup History") ' calendar moving copy to Set mainCalFolder = GetFolderPath("\\david.lane@fraserhealth.ca\Calendar") Set NS = Nothing End Sub Sub kill_handler() Dim NS As Outlook.NameSpace Set NS = Application.GetNamespace("MAPI") Set curCal = NS.GetDefaultFolder(olFolderDrafts).Items Set curCal2 = NS.GetDefaultFolder(olFolderDrafts).Items End Sub '-------------------------------------- '----start of create second item calendar code Private Sub curCal_ItemAdd(ByVal Item As Object) Dim cAppt As AppointmentItem Dim moveCal As AppointmentItem 'event handler off Call kill_handler ' On Error Resume Next 'remove to make a copy of all items If Item.BusyStatus <> olFee Then ' Item.Body = Item.Body & "[" & GetDATETIME & "]" Item.Body = Item.Body & "Original Date: " & GetDATETIME 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 '.Body = Item.Body & "[" & GetDATETIME & "]" End With ' set the category after it's moved to force EAS to sync changes Set moveCal = cAppt.Move(newCalFolder) moveCal.Categories = "Backup" moveCal.Save End If 'event handler on Call Initialize_handler End Sub Private Sub curCal_ItemChange(ByVal Item As Object) Dim cAppt As AppointmentItem Dim objAppointment As AppointmentItem Dim strBody As String On Error Resume Next ' use 2 + the length of GetDATETIME string strBody = Right(Item.Body, 21) For Each objAppointment In newCalFolder.Items If InStr(1, objAppointment.Body, strBody) Then Set cAppt = objAppointment cAppt.Delete End If Next Call kill_handler With Item If Item.BusyStatus <> olFee Then '.BodyFormat = olFormatHTML '.HTMLBody = "

The body of this message will appear in HTML.

Type the message text here. " ' Item.Body = "bla bla bla" & mailbody.Font.Underline & "bla bla" & .Font.Bold & Body = Msht.Range("N2") Item.Body = "Updated: " & GetDATETIME & vbCrLf & vbCrLf & Item.Body Item.Save End If End With Set cAppt = Application.CreateItem(olAppointmentItem) With cAppt .Subject = "Copied: " & Item.Subject .Start = Item.Start .Duration = Item.Duration .Location = Item.Location .Body = Item.Body '.Body = Item.Body & "[" & GetDATETIME & "]" End With ' set the category after it's moved to force EAS to sync changes Set moveCal = cAppt.Move(newCalFolder) moveCal.Categories = "Backup" moveCal.Save Call Initialize_handler End Sub