VBA: Копирование событий из одного календаря в другой

Dim WithEvents curCalendar As Outlook.Folder
Dim WithEvents curCalendarItems As Outlook.Items
Dim newCalFolder As Outlook.Folder
Dim WithEvents objDelFolder As Outlook.Folder

Private Sub Application_Startup()
    Dim NS As Outlook.NameSpace
    Set NS = Application.GetNamespace("MAPI")
    
    ' default calendar
    Set curCalendar = Outlook.Session.GetDefaultFolder(olFolderCalendar)
    Set curCalendarItems = curCalendar.Items
    
    'calendar you are copying to
    Set objOwner = NS.CreateRecipient("calendar-test@cloud.local")
    'Set objOwner = NS.CreateRecipient("test_tt@domain.ru")
    objOwner.Resolve
    
    If objOwner.Resolved Then
        Debug.Print objOwner.Name
        Set newCalFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
        Set Items = newCalFolder.Items
    End If
    
    'Set newCalFolder = GetFolderPath("calendar-test@cloud.local\Календарь")
    'Set newCalFolder = GetFolderPath("test_tt@domain.ru\Календарь")
    
    Set NS = Nothing
    
    'deleted items folder
    Set objDelFolder = Application.Session.GetDefaultFolder(olFolderDeletedItems)
End Sub

Public Sub curCalendarItems_ItemAdd(ByVal Item As Object)
    Dim cAppt As AppointmentItem
    Dim moveCal As AppointmentItem
    
    If Item.BusyStatus = olBusy Then
        Item.Body = Item.Body & vbNewLine & vbNewLine & vbNewLine & "DO NOT DELETE GUID below to maintain calendar sync." & vbNewLine & "[" & GetGUID & "]"
        Item.Save
        
        Set cAppt = Application.CreateItem(olAppointmentItem)
        Set cAppt = Application.CreateItem(olAppointmentItem)
        
        With cAppt
            .Subject = "Sync: " & Item.Subject
            .Start = Item.Start
            .Duration = Item.Duration
            .Location = Item.Location
            .Body = Item.Body
            .ReminderSet = False
        End With
        
        Debug.Print "cAppt curCalendarItems_ItemAdd = " & cAppt.Subject
        
        ' set the category after it's moved to force EAS to sync changes
        Set moveCal = cAppt.Move(newCalFolder)
        moveCal.Categories = "category"
        moveCal.Save
    End If
End Sub

Public Sub curCalendarItems_ItemChange(ByVal Item As Object)
    Dim cAppt As AppointmentItem
    Dim objAppointment As AppointmentItem
    Dim strStart, strSubject As String
    
    On Error Resume Next
    
    strSubject = "Sync: " & Item.Subject
    strStart = Item.Start
    
    Debug.Print "strSubject = " & strSubject
    
    ' find the left bracket and then use 2 + the length of the GUID
    'strbody = Right(Item.Body, 38)
    strbody = Mid(Item.Body, InStr(Item.Body, "["), 38)
    
    For Each objAppointment In newCalFolder.Items
        If InStr(1, objAppointment.Body, strbody) Then
            Set cAppt = objAppointment
        End If
    Next
    
    For Each objAppointment In newCalFolder.Items
        If objAppointment.Subject = strSubject And objAppointment.Start = strStart Then
            Set cAppt = objAppointment
        End If
    Next
    
    With cAppt
        .Subject = "Sync: " & Item.Subject
        .Start = Item.Start
        .Duration = Item.Duration
        .Location = Item.Location
        .Body = Item.Body
        .Save
    End With
    
    Debug.Print "cAppt curCalendarItems_ItemChange = " & cAppt.Subject
    
End Sub

Public Sub curCalendar_BeforeItemMove(ByVal Item As Object, ByVal MoveTo As MAPIFolder, Cancel As Boolean)
    Dim cAppt As AppointmentItem
    Dim objAppointment As AppointmentItem
    Dim strStart, strSubject As String
    
    On Error Resume Next
    
    'MsgBox "BeforeItemMove sub"
    
    For Each objAppointment In newCalFolder.Items
        If MoveTo Is Nothing Then
            Debug.Print Item.Subject & " was hard deleted"
            'MsgBox "Hard deleted."
            strSubject = "Sync: " & Item.Subject
            strStart = Item.Start
            ' find the left bracket and then use 2 + the length of the GUID
            strbody = Mid(Item.Body, InStr(Item.Body, "["), 38)
            
            Debug.Print "strbody1 = " & strbody
            
            If InStr(1, objAppointment.Body, strbody) Then
                Set cAppt = objAppointment
            ElseIf objAppointment.Subject = strSubject And objAppointment.Start = strStart Then
                Set cAppt = objAppointment
            End If
            
            With cAppt
                .Subject = "Cancelled: " & Item.Subject
                .Start = Item.Start
                .Duration = Item.Duration
                .Location = Item.Location
                .Body = Item.Body
                .BusyStatus = olFree
                .Save
                .Delete
            End With
        
        ElseIf MoveTo = objDelFolder Then
            'MsgBox "Moved to deleted folder."
            strSubject = "Sync: " & Item.Subject
            strStart = Item.Start
            
            ' find the left bracket and then use 2 + the length of the GUID
            strbody = Mid(Item.Body, InStr(Item.Body, "["), 38)
            
            'MsgBox strbody
            Debug.Print "strbody2 = " & strbody
            
            If InStr(1, objAppointment.Body, strbody) Then
                Set cAppt = objAppointment
            ElseIf objAppointment.Subject = strSubject And objAppointment.Start = strStart Then
                Set cAppt = objAppointment
            End If
            
            With cAppt
                .Subject = "Cancelled: " & Item.Subject
                .Start = Item.Start
                .Duration = Item.Duration
                .Location = Item.Location
                .Body = Item.Body
                .BusyStatus = olFree
                .Save
                .Delete
            End With
        End If
    Next
End Sub

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

Public Function GetGUID() As String
    GetGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
End Function