How to remove duplicate calendar events from Lookout


    1. From Outlook, open your macro editor. (Either press alt-F11 or select Tools, Macro, Visual Basic Editor.)
    2. In the macro editor window, select Insert, Module. This will create a text editor window into which you can paste the macro.
    3. In the text editor window, paste in the code below. (I recommend you review the code to be sure it's doing what you want.)
    4. You can run the code by placing your cursor anywhere in the code window between the "Sub" and "End Sub" statements and pressing F5. Optionally, you can close the Visual Basic window, then select Tools, Macro, Macros..., and "Run" RemoveDuplicateEvents.

    The last section of the macro removes all items from your Deleted Items folder. I discovered this is important, because events in my Deleted Items folder "mysteriously" kept re-duplicating. Once I cleaned out the folder, my sync'ing was successful.

    Here is the code for the macro. Hopefully, it is useful to someone. Please let me know if you have any problems so I can correct it. Also, I have similar macros to remove duplicate contacts and notes if anyone is interested.

    ':::::::::::::::::: 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 = 0FreeBusyStatus = 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
    With olAppointment1
    If .Subject = olAppointment2.Subject And _
    .Start = olAppointment2.Start Then
    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
    Debug.Print .Subject & " updated!"
    End If
    .BusyStatus = olFree
    Debug.Print .Subject & " updated!"
    End If
    End If
    End With
    End If
    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
    End If
    MsgBox "Cleanup Complete!", vbOKOnly, "End of Processing"
    End Sub
    ':::::::::::::::::: Macro Ends Here

    No questions yet.