Как удалить дубликаты в аутлук календаре?

Есть скрипт-макрос, который нужно один раз запустить в Visual Basic в самом Outlook.

Вот код:

':::::::::::::::::: Macro Begins Here; Copy this line and everything below
Sub RemoveDuplicateEvents()
Dim olApp As Outlook.Application
Dim olAppointment1 As Outlook.AppointmentItem
Dim olAppointment2 As Outlook.AppointmentItem
Dim olItems As Outlook.I

Есть скрипт-макрос, который нужно один раз запустить в Visual Basic в самом Outlook.

Вот код:

':::::::::::::::::: Macro Begins Here; Copy this line and everything below
Sub RemoveDuplicateEvents()
Dim olApp As Outlook.Application
Dim olAppointment1 As Outlook.AppointmentItem
Dim olAppointment2 As Outlook.AppointmentItem
Dim olItems As Outlook.Items
Dim olDeletedItems As Outlook.Items
Dim olNS As Outlook.NameSpace
Dim SkipConfirmation As Boolean


Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olItems = olNS.GetDefaultFolder(olFolderCalendar).Items
Set olDeletedItems = olNS.GetDefaultFolder(olFolderDeletedItems).Items

olItems.Sort ("Subject")
olItems.Sort ("Start")
Dim DeleteCount As Integer
Dim z As Integer
Dim FreeBusyStatus As Boolean
DeleteCount = 0

FreeBusyStatus = MsgBox("Do you want to set the status for all-day events to 'Free'?", vbYesNo, "Set Free Busy Status") = vbYes
If FreeBusyStatus Then
SkipConfirmation = Not MsgBox("Do you want to be prompted to set free times for all-day events?", vbYesNo, "Skip Confirmation?") = vbYes
End If

For z = olItems.Count To 2 Step -1
If Not (Len(olItems.Item(z).Subject) = 36 And InStr(1, olItems.Item(z), " ") > 0) And _
Not (Len(olItems.Item(z - 1).Subject) = 36 And InStr(1, olItems.Item(z - 1), " ") > 0) Then

Set olAppointment1 = olItems.Item(z)
Set olAppointment2 = olItems.Item(z - 1)
Debug.Print olAppointment1.Subject & vbCrLf & olAppointment2.Subject
DoEvents

With olAppointment1
If .Subject = olAppointment2.Subject And _
.Start = olAppointment2.Start Then
.Delete
Debug.Print "Calendar item " & Left(olAppointment2.Subject, 25) & "..." & " deleted"
DeleteCount = DeleteCount + 1
End If
End With
With olAppointment2
If .AllDayEvent And .BusyStatus <> olFree And FreeBusyStatus Then
If Not SkipConfirmation Then
If MsgBox("Do you want to set """ & .Subject & """ as free time?", vbYesNo, "Confirm Status Change") = vbYes Then
.BusyStatus = olFree
.Save
Debug.Print .Subject & " updated!"
End If
Else
.BusyStatus = olFree
.Save
Debug.Print .Subject & " updated!"
End If
End If
End With
End If
Next
If MsgBox(DeleteCount & " duplicate Outlook calendar items have been removed." & _
vbCrLf & "Do you want to clear your deleted items folder?" & vbCrLf & _
"(This must be done to prevent re-syncing 'deleted' entries)", vbYesNo, "Confirm Deleted Items Removal") = vbYes Then
' Clear deleted items folder
For z = olDeletedItems.Count To 1 Step -1
olDeletedItems.Item(z).Delete
DoEvents
Next
End If
MsgBox "Cleanup Complete!", vbOKOnly, "End of Processing"

End Sub

':::::::::::::::::: Macro Ends Here

Есть скрипт-макрос, который нужно один раз запустить в Visual Basic в самом Outlook.

Вот код:

':::::::::::::::::: Macro Begins Here; Copy this line and everything below
Sub RemoveDuplicateEvents()
Dim olApp As Outlook.Application
Dim olAppointment1 As Outlook.AppointmentItem
Dim olAppointment2 As Outlook.AppointmentItem
Dim olItems As Outlook.I

Есть скрипт-макрос, который нужно один раз запустить в Visual Basic в самом Outlook.

Вот код:

':::::::::::::::::: Macro Begins Here; Copy this line and everything below
Sub RemoveDuplicateEvents()
Dim olApp As Outlook.Application
Dim olAppointment1 As Outlook.AppointmentItem
Dim olAppointment2 As Outlook.AppointmentItem
Dim olItems As Outlook.Items
Dim olDeletedItems As Outlook.Items
Dim olNS As Outlook.NameSpace
Dim SkipConfirmation As Boolean


Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olItems = olNS.GetDefaultFolder(olFolderCalendar).Items
Set olDeletedItems = olNS.GetDefaultFolder(olFolderDeletedItems).Items

olItems.Sort ("Subject")
olItems.Sort ("Start")
Dim DeleteCount As Integer
Dim z As Integer
Dim FreeBusyStatus As Boolean
DeleteCount = 0

FreeBusyStatus = MsgBox("Do you want to set the status for all-day events to 'Free'?", vbYesNo, "Set Free Busy Status") = vbYes
If FreeBusyStatus Then
SkipConfirmation = Not MsgBox("Do you want to be prompted to set free times for all-day events?", vbYesNo, "Skip Confirmation?") = vbYes
End If

For z = olItems.Count To 2 Step -1
If Not (Len(olItems.Item(z).Subject) = 36 And InStr(1, olItems.Item(z), " ") > 0) And _
Not (Len(olItems.Item(z - 1).Subject) = 36 And InStr(1, olItems.Item(z - 1), " ") > 0) Then

Set olAppointment1 = olItems.Item(z)
Set olAppointment2 = olItems.Item(z - 1)
Debug.Print olAppointment1.Subject & vbCrLf & olAppointment2.Subject
DoEvents

With olAppointment1
If .Subject = olAppointment2.Subject And _
.Start = olAppointment2.Start Then
.Delete
Debug.Print "Calendar item " & Left(olAppointment2.Subject, 25) & "..." & " deleted"
DeleteCount = DeleteCount + 1
End If
End With
With olAppointment2
If .AllDayEvent And .BusyStatus <> olFree And FreeBusyStatus Then
If Not SkipConfirmation Then
If MsgBox("Do you want to set """ & .Subject & """ as free time?", vbYesNo, "Confirm Status Change") = vbYes Then
.BusyStatus = olFree
.Save
Debug.Print .Subject & " updated!"
End If
Else
.BusyStatus = olFree
.Save
Debug.Print .Subject & " updated!"
End If
End If
End With
End If
Next
If MsgBox(DeleteCount & " duplicate Outlook calendar items have been removed." & _
vbCrLf & "Do you want to clear your deleted items folder?" & vbCrLf & _
"(This must be done to prevent re-syncing 'deleted' entries)", vbYesNo, "Confirm Deleted Items Removal") = vbYes Then
' Clear deleted items folder
For z = olDeletedItems.Count To 1 Step -1
olDeletedItems.Item(z).Delete
DoEvents
Next
End If
MsgBox "Cleanup Complete!", vbOKOnly, "End of Processing"

End Sub

':::::::::::::::::: Macro Ends Here