How to remove duplicate calendar events from Lookout

    From https://www.google.com/support/forum/p/Calendar/thread?tid=06cc66355f97d57c&hl=en

    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

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

    No questions yet.

    Main Menu