Now that I've tested it, I found some problems and fixed them. Below is the
updated class:
'---------------------------------------------------------------------------------------
' Module : clsDuplicatesScanner
' DateTime : 10/24/2005 16:36
' Author : Eric Legault (MVP - Outlook)
' Purpose : Requires Project Reference to Microsoft Collaboration Data
Objects 1.21
'---------------------------------------------------------------------------------------
'To use this class, follow this example:
'Sub ScanForDuplicates()
' Dim clsDupScanner As clsDuplicatesScanner
' Dim objNS As Outlook.NameSpace
'
' Set objNS = Application.GetNamespace("MAPI")
' Set clsDupScanner = New clsDuplicatesScanner
'
' Set clsDupScanner.SourceFolder = objNS.PickFolder
' Set clsDupScanner.CompareFolder = objNS.PickFolder
' clsDupScanner.ScanFolder ScanTwoFolders
'
'Leave:
' Set clsDupScanner = Nothing
' Set objNS = Nothing
'End Sub
'---------------------------------------------------------------------------------------
Option Explicit
Private m_objSession As MAPI.Session
Private m_objSourceFolder As MAPIFolder
Private m_objCompareFolder As MAPIFolder
Private m_eScanMode As ScanModes
Const CdoPR_FLAG_ICON = &H10950003 'PT_LONG
Const CdoPR_FLAG_MARKED = &H10960003 'PT_LONG
Const CdoPR_FLAG_STATUS = &H10900003 'Outlook Flag status: 0 = No flag, 1 =
White flag, 2 = Red flag
Const CdoPR_REPLY_REQUESTED = &HC17000B 'True/False
Const CdoPR_RESPONSE_REQUESTED = &H63000B 'True/False
Enum ScanModes
ScanSingleFolder = 0
ScanTwoFolders = 2
End Enum
Private Sub Class_Initialize()
On Error Resume Next
Set m_objSession = New MAPI.Session
m_objSession.Logon , , , False
End Sub
Private Sub Class_Terminate()
On Error Resume Next
m_objSession.Logoff
Set m_objSession = Nothing
Set m_objSourceFolder = Nothing
Set m_objCompareFolder = Nothing
End Sub
'---------------------------------------------------------------------------------------
' Procedure : ScanFolder
' DateTime : 10/24/2005 16:31
' Author : ericl
' Purpose : Will tag any duplicate items in CompareFolder (as compared
with SourceFolder)
' : with Yellow Quick Flags; the earliest received non-duplicate
will be tagged
' : with a Green Quick Flag
'---------------------------------------------------------------------------------------
'
Public Sub ScanFolder(SetScanMode As ScanModes)
On Error Resume Next
Dim objFoundItems As Outlook.Items
Dim objItem As Object, objFoundItem As Object
Dim intX As Integer, strCrit As String
Dim intDupes As Integer
Dim intDuplicateLimit As Integer
ScanMode = SetScanMode
'Validate class settings
Select Case ScanMode
Case ScanModes.ScanSingleFolder
If Me.SourceFolder Is Nothing Then
MsgBox "You must set the folder you want to search for
duplicate items." _
, vbOKOnly + vbExclamation, "Invalid Folder"
GoTo Leave:
End If
If SourceFolder.DefaultItemType <> olMailItem And
SourceFolder.DefaultItemType <> olPostItem Then
MsgBox "The Duplicates Scanner class is only designed to
work with Mail or Post folders." _
, vbOKOnly + vbExclamation, "Invalid Folder Type"
GoTo Leave:
End If
Set Me.CompareFolder = Me.SourceFolder
intDuplicateLimit = 1 'When searching the same folder, must take
into account that a search
'will return the source item itself, so a match for duplicates
must be two or more
Case ScanModes.ScanTwoFolders
If Me.SourceFolder Is Nothing Then
MsgBox "You must set the source folder to search for
duplicate items." _
, vbOKOnly + vbExclamation, "Invalid Folder"
GoTo Leave:
End If
If Me.CompareFolder Is Nothing Then
MsgBox "You must set the folder you want to compare against
the source folder for duplicate items." _
, vbOKOnly + vbExclamation, "Invalid Folder"
GoTo Leave:
End If
If SourceFolder.DefaultItemType <> olMailItem And
SourceFolder.DefaultItemType <> olPostItem Then
MsgBox "The Duplicates Scanner class is only designed to
work with Mail or Post folders." _
, vbOKOnly + vbExclamation, "Invalid Folder Type"
GoTo Leave:
End If
If CompareFolder.DefaultItemType <> olMailItem And
CompareFolder.DefaultItemType <> olPostItem Then
MsgBox "The Duplicates Scanner class is only designed to
work with Mail or Post folders." _
, vbOKOnly + vbExclamation, "Invalid Folder Type"
GoTo Leave:
End If
intDuplicateLimit = 0
End Select
For Each objItem In SourceFolder.Items
If HasFlag(objItem) = False Then
strCrit = Replace(objItem.Subject, """, """"", 1, , vbTextCompare)
strCrit = Replace(strCrit, "'", "''", 1, , vbTextCompare)
Set objFoundItems = CompareFolder.Items.Restrict("[Subject] = '"
& strCrit & "'")
If objFoundItems.Count > intDuplicateLimit Then
'Duplicates found; tag them
objFoundItems.Sort ("[Received]"), True
intX = 0
For Each objFoundItem In objFoundItems
intX = intX + 1
If ScanMode = ScanSingleFolder Then
'Good idea to set flags to differentiate the
candidate message to keep,
'and the others to delete
If intX <> objFoundItems.Count Then
'Flag all items except the last (the earliest)
SetFlag objFoundItem, olYellowFlagIcon
objFoundItem.Save
Else
SetFlag objFoundItem, olGreenFlagIcon 'Tag as
green for keep
objFoundItem.Save
End If
Else
'In multiple folders, the items in the source folder
will always be kept;
'No need to flag source items in that case
SetFlag objFoundItem, olYellowFlagIcon
objFoundItem.Save
End If
Next
intDupes = intDupes + 1
End If
End If
Next
MsgBox "Duplicates found: " & intDupes, vbOKOnly + vbInformation, "Scan
Complete"
If intDupes <> 0 Then
If MsgBox("Permanently delete all yellow-flagged messages?", vbYesNo
+ vbQuestion, "Delete All?") = vbNo Then GoTo Leave:
DeleteYellowFlagMessages
End If
Leave:
Set objFoundItems = Nothing
Set objFoundItem = Nothing
Set objItem = Nothing
End Sub
Private Sub SetFlag(OutlookItemObj As Object, FlagColour As OlFlagIcon)
On Error Resume Next
Dim objCDOMessageObj As Object
Dim objField As MAPI.Field, objFields As MAPI.Fields
'Assuming an open CDO Session
Set objCDOMessageObj = m_objSession.GetMessage(OutlookItemObj.EntryID,
OutlookItemObj.Parent.StoreID)
Set objFields = objCDOMessageObj.Fields
objFields.Add CdoPR_FLAG_MARKED, 2
objFields.Add CdoPR_FLAG_STATUS, 1 '1 is set when a flag is applied
manually; was 2
objFields.Add CdoPR_REPLY_REQUESTED, True
objFields.Add CdoPR_RESPONSE_REQUESTED, True
objFields.Add CdoPR_FLAG_ICON, FlagColour
objCDOMessageObj.Update
Set objCDOMessageObj = Nothing
Set objField = Nothing
Set objFields = Nothing
End Sub
Private Function HasFlag(OutlookItemObj As Object) As Boolean
On Error Resume Next
Dim objCDOMessageObj As Object
Dim objField As MAPI.Field, objFields As MAPI.Fields
'Assuming an open CDO Session
Set objCDOMessageObj = m_objSession.GetMessage(OutlookItemObj.EntryID,
OutlookItemObj.Parent.StoreID)
Set objFields = objCDOMessageObj.Fields
Set objField = objCDOMessageObj.Fields(CdoPR_FLAG_STATUS)
If Err.Number = 0 Then 'error if field doesn't exist
If objField.Value = 1 Then
HasFlag = True
End If
End If
Set objCDOMessageObj = Nothing
Set objField = Nothing
Set objFields = Nothing
End Function
Private Sub DeleteYellowFlagMessages()
On Error Resume Next
Dim objFolder As Outlook.MAPIFolder, intX As Integer
Dim objMessage As MAPI.Message
Dim objItems As Outlook.Items
Set objFolder = ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
For intX = objItems.Count To 1 Step -1
Set objMessage =
m_objSession.GetMessage(objItems.Item(intX).EntryID, objFolder.StoreID)
objMessage.Delete
Set objMessage = Nothing
Next
Set objItems = Nothing
Set objFolder = Nothing
End Sub
Public Property Get SourceFolder() As MAPIFolder
Set SourceFolder = m_objSourceFolder
End Property
Public Property Set SourceFolder(objSourceFolder As MAPIFolder)
Set m_objSourceFolder = objSourceFolder
End Property
Public Property Get CompareFolder() As MAPIFolder
Set CompareFolder = m_objCompareFolder
End Property
Public Property Set CompareFolder(objCompareFolder As MAPIFolder)
Set m_objCompareFolder = objCompareFolder
End Property
Private Property Get ScanMode() As ScanModes
ScanMode = m_eScanMode
End Property
Private Property Let ScanMode(ByVal eScanMode As ScanModes)
m_eScanMode = eScanMode
End Property
A hint: use