Remove duplicate items keeping the copy that has been read - vba

Question

The code below removes duplicate items from a folder in Outlook.
My request:
If two exact items exist, keep the copy that has been read, and delete the copy that has not been read.
Sub RemoveDuplicateItems()
Dim objFolder As Folder
Dim objDictionary As Object
Dim i As Long
Dim objItem As Object
Dim strKey As String
Set objDictionary = CreateObject("scripting.dictionary")
'Select a source folder
Set objFolder = Outlook.Application.Session.PickFolder
If Not (objFolder Is Nothing) Then
For i = objFolder.Items.Count To 1 Step -1
Set objItem = objFolder.Items.Item(i)
Select Case objFolder.DefaultItemType
'Check email subject, body and sent time
Case olMailItem
strKey = objItem.Subject & "," & objItem.Body & "," & objItem.SentOn
'Check appointment subject, start time, duration, location and body
Case olAppointmentItem
strKey = objItem.Subject & "," & objItem.Start & "," & objItem.Duration & "," & objItem.Location & "," & objItem.Body
'Check contact full name and email address
Case olContactItem
strKey = objItem.FullName & "," & objItem.Email1Address & "," & objItem.Email2Address & "," & objItem.Email3Address
'Check task subject, start date, due date and body
Case olTaskItem
strKey = objItem.Subject & "," & objItem.StartDate & "," & objItem.DueDate & "," & objItem.Body
End Select
strKey = Replace(strKey, ", ", Chr(32))
'Remove the duplicate items
If objDictionary.Exists(strKey) = True Then
objItem.Delete
Else
objDictionary.Add strKey, True
End If
Next i
End If
End Sub

Answer 1

You could save EntryId to delete an item with data previously saved in the dictionary.
Check each item instead of assuming the type will be the default type for the folder.
Option Explicit
Sub RemoveDuplicateUnreadItems()
' Remove duplicates, with a preference for unread items
Dim objFolder As Folder
Dim objDictionary As Object
Dim i As Long
Dim objItem As Object
Dim strKey As String
Dim dictionaryItem As Object
Set objDictionary = CreateObject("scripting.dictionary")
'Select a source folder
'Set objFolder = Session.PickFolder
Set objFolder = Session.GetDefaultFolder(olFolderInbox).Folders("Test")
If Not (objFolder Is Nothing) Then
For i = objFolder.Items.count To 1 Step -1
Set objItem = objFolder.Items.Item(i)
Select Case objItem.Class
'Check email subject, body and sent time
Case olMail
strKey = objItem.Subject & "," & objItem.Body & "," & objItem.SentOn
'Check appointment subject, start time, duration, location and body
Case olAppointment
strKey = objItem.Subject & "," & objItem.Start & "," & objItem.duration & "," & objItem.Location & "," & objItem.Body
'Check contact full name and email address
Case olContact
strKey = objItem.fullName & "," & objItem.Email1Address & "," & objItem.Email2Address & "," & objItem.Email3Address
'Check task subject, start date, due date and body
Case olTask
strKey = objItem.Subject & "," & objItem.startDate & "," & objItem.DueDate & "," & objItem.Body
Case Else
Debug.Print "Unexpected class: " & objItem.Class
'MsgBox "Unexpected class: " & objItem.Class
'objItem.Display
GoTo skipClass
End Select
strKey = Replace(strKey, ", ", Chr(32))
'Debug.Print objItem.Subject
'Remove the duplicate items
If objDictionary.Exists(strKey) = True Then
Debug.Print objItem.Subject
If objItem.UnRead = True Then
Debug.Print "objItem.Delete"
objItem.Delete
Else
' Replace existing without further verification
Set dictionaryItem = Session.GetItemFromID(objDictionary(strKey))
Debug.Print "dictionaryItem.Delete"
dictionaryItem.Delete
objDictionary(strKey) = objItem.EntryID
End If
Else
objDictionary.Add strKey, objItem.EntryID
End If
skipClass:
Next i
End If
Debug.Print "Done."
End Sub