Тема: VBA: Копирование событий из одного календаря в другой
Всем привет.
Ситуация следующая. Есть у нас в конторе секретарь, у которой в Outlook подключено две почтовые учётки руководителя - первая наша доменная корпоративная и вторая из другого домена, с которым у нас есть локальный линк, но между доменами нет доверия.
Секретарь планирует рабочий день руководителя, создавая новые события в календаре сначала для нашего доменного, а потом то же самое руками для второго подключенного из другого домена (там более высокое руководство).
Поставили задачу это дело автоматизировать. Создавать события только в календаре учётки из нашего домена, чтобы они копировались во второй. А так же учитывались все изменения событий, удаление, вот это всё.
Естественно, первым делом я полез в гугл. И на просторах наткнулся на нужный мне скрипт:
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
Здесь
test_tt@domain.ru - это наша доменная учетка;
calendar-test@cloud.local - это учетка из другого домена.
Если подключать календарь нашей доменной учетки как расшаренный календарь, то всё хорошо. События копируются, меняются, отменяются, удаляются. Но если подключить учетку как вторую почтовую учетную запись, то болт. Событие копируется, но никаких изменений не применяется, удаление тоже.
Вопрос. Как сделать так, чтобы скрипт работал не для подключенного расшаренного календаря, а для второго подключенного почтового ящика из другого домена? Чувствую, что дело в каком-то мелком параметре, но понять уже не могу...