compare two email folders and delete dubble items?

vonclausowitz · Oct 24, 2005

Hi,

I need a code sample on how to compare two email folders and delete
emails which are already in the other folder.

I have my Inbox which I want to compare, thru a macro, with the folder
Deleted Items. I saw something on removing double emails from one
folder but not this kind of code.

The code has to cross-check all the emails in my inbox with the emails
in the Deleted Items (which is actually from another account) and if he
already has these items in his Deleted Items, they can be removed from
my Inbox as well (becasue than he already transferred them).

Marco

Guest · Oct 24, 2005

Try this class that I've created. It should be self-explanatory; if not, let
me know how I can help.

'---------------------------------------------------------------------------------------
' 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

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
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
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 > 1 Then
'Duplicates found; tag them
objFoundItems.Sort ("[Received]"), True
intX = 0
For Each objFoundItem In objFoundItems
intX = intX + 1
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
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

vonclausowitz · Oct 25, 2005

Eric,

Thanks a lot for this code sample, it looks great.
I tried the code but it doesn't return any duplicate messages.
When will it return a duplicate? I send one message to both my
accounts, so I ended up with two message (which I think are identical)
but he doesn't find them.

Marco

Guest · Oct 25, 2005

I have to admit - I never tested that code! Actually that's not completely
true - I modified it to do comparisons on two folders when searching for
duplicates. It was originally used just to search on one folder, which
worked fine for me.

Maybe it depends on what you consider a duplicate. My class simply compares
the Subject line. Are you using the class in ScanTwoFolders mode, and have
you set both the SourceFolder and CompareFolder objects to the two different
folders?

vonclausowitz · Oct 25, 2005

Maybe it depends on what you consider a duplicate. My class simply
compares
the Subject line.

Marco: that's OK with me, although it might be better to include date
received, if that's possible!!!!!

Are you using the class in ScanTwoFolders mode, and have
you set both the SourceFolder and CompareFolder objects to the two
different
folders?

Marco: Yes if have.

Guest · Oct 26, 2005

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

vonclausowitz · Oct 26, 2005

Eric,

Code works a little bit better...... there's only one minor problem.
When testing the code I answered YES to the Question if I wanted to
remove the Yellow flagged messages. Assuming that it would delete the
duplicate message, it deleted all the messages in my folder.... NOT
GREAT!

Marco

Guest · Oct 26, 2005

Yikes! I'm terribly sorry Marco. I should have tested that bit again. That
procedure actually assumes that a view has been created in the currently
selected folder with a restriction on only showing items with yellow flags.

This solution was orginally written for a one time operation that I wanted
to do on some duplicate items that I had. It was very similar to your
problem, so I thought I'd just slightly modify it to fit your scenario. I
obviously failed to remember the assumptions that the code works with.

Basically, get rid of that whole procedure.

vonclausowitz · Oct 26, 2005

Eric,

Never mind the emails... there are worse things in the world.
Isn't there a way to solve this? Why get rid of the whole procedure, I
like it.

Or maybe just lose the part where you can choose to delete all the
flagged messages.

Marco

Guest · Oct 26, 2005

Do you want the ability to delete all of the e-mails in the compare folder
that have yellow flags? If so, consider it your homework. :-)

A hint: use
CdoPR_FLAG_ICON with CDO's Messages.Filter property...

If you don't want the delete functionality, remove DeleteYellowFlagMessages
and the call to it at the end of the ScanFolder procedure.

vonclausowitz · Oct 27, 2005

Eric,

I will try to work something out with the filter option.
I also found another small bug. My Win 2000 at my working location
doesn't recognize the olYellowFlagItem. I think it has something to do
with my outlook version. Maybe too old?

Marco

Eric Legault [MVP - Outlook] schreef:

vonclausowitz · Oct 27, 2005

I have been trying the following, but with the same result... all the
emails get deleted, also the ones without a flag!

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
Dim objField As MAPI.Field, objFields As MAPI.Fields
' Dim objMessageFilter As MAPI.Field

Set objFolder = ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
' Set objMessageFilter = objFolder.Messages.Filter
' objMsgFilter.fields(CdoPR_FLAG_ICON) =

For intX = objItems.Count To 1 Step -1
Set objMessage =
m_objSession.GetMessage(objItems.item(intX).EntryID, objFolder.StoreID)
Set objFields = objMessage.Fields
Set objField = objMessage.Fields(CdoPR_FLAG_STATUS)
If objField.Value = 1 Then 'indien een witte vlag dan
verwijderen
objMessage.Delete
End If
Set objMessage = Nothing
Next

Set objItems = Nothing
Set objFolder = Nothing
End Sub

Marco

(e-mail address removed) schreef:

Eric,

I will try to work something out with the filter option.
I also found another small bug. My Win 2000 at my working location
doesn't recognize the olYellowFlagItem. I think it has something to do
with my outlook version. Maybe too old?

Marco

Eric Legault [MVP - Outlook] schreef:

Do you want the ability to delete all of the e-mails in the compare folder
that have yellow flags? If so, consider it your homework. A hint: use
CdoPR_FLAG_ICON with CDO's Messages.Filter property...

If you don't want the delete functionality, remove DeleteYellowFlagMessages
and the call to it at the end of the ScanFolder procedure.

--
Eric Legault (Outlook MVP, MCDBA, old school WOSA MCSD, B.A.)
Try Picture Attachments Wizard for Outlook:
http://www.collaborativeinnovations.ca
Blog: http://blogs.officezealot.com/legault/

Click to expand...

Guest · Oct 27, 2005

The value for a Yellow flag is 4, and I believe coloured flag support (other
than Red) started in Outlook 2002. Here's the modified code that should work
- but comment out the Delete call until you are sure it works fine!!

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
Dim objField As MAPI.Field, objFields As MAPI.Fields
' Dim objMessageFilter As MAPI.Field

Set objFolder = ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
' Set objMessageFilter = objFolder.Messages.Filter
' objMsgFilter.fields(CdoPR_FLAG_ICON) =

For intX = objItems.Count To 1 Step -1
Set objMessage =
m_objSession.GetMessage(objItems.Item(intX).EntryID, objFolder.StoreID)
Set objFields = objMessage.Fields
Set objField = objMessage.Fields(CdoPR_FLAG_ICON)
If Not objField Is Nothing Then
If objField.Value = 4 Then 'indien een witte vlag dan
verwijderen
objMessage.Delete
End If
End If
Set objField = Nothing
Set objMessage = Nothing
Next

Set objItems = Nothing
Set objFolder = Nothing
End Sub

--
Eric Legault (Outlook MVP, MCDBA, old school WOSA MCSD, B.A.)
Try Picture Attachments Wizard for Outlook:
http://www.collaborativeinnovations.ca
Blog: http://blogs.officezealot.com/legault/

[email protected] said:
I have been trying the following, but with the same result... all the
emails get deleted, also the ones without a flag!

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
Dim objField As MAPI.Field, objFields As MAPI.Fields
' Dim objMessageFilter As MAPI.Field

Set objFolder = ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
' Set objMessageFilter = objFolder.Messages.Filter
' objMsgFilter.fields(CdoPR_FLAG_ICON) =

For intX = objItems.Count To 1 Step -1
Set objMessage =
m_objSession.GetMessage(objItems.item(intX).EntryID, objFolder.StoreID)
Set objFields = objMessage.Fields
Set objField = objMessage.Fields(CdoPR_FLAG_STATUS)
If objField.Value = 1 Then 'indien een witte vlag dan
verwijderen
objMessage.Delete
End If
Set objMessage = Nothing
Next

Set objItems = Nothing
Set objFolder = Nothing
End Sub

Marco

(e-mail address removed) schreef:

Eric,

I will try to work something out with the filter option.
I also found another small bug. My Win 2000 at my working location
doesn't recognize the olYellowFlagItem. I think it has something to do
with my outlook version. Maybe too old?

Marco

Eric Legault [MVP - Outlook] schreef:

Do you want the ability to delete all of the e-mails in the compare folder
that have yellow flags? If so, consider it your homework. A hint: use
CdoPR_FLAG_ICON with CDO's Messages.Filter property...

If you don't want the delete functionality, remove DeleteYellowFlagMessages
and the call to it at the end of the ScanFolder procedure.

--
Eric Legault (Outlook MVP, MCDBA, old school WOSA MCSD, B.A.)
Try Picture Attachments Wizard for Outlook:
http://www.collaborativeinnovations.ca
Blog: http://blogs.officezealot.com/legault/

:

Eric,

Never mind the emails... there are worse things in the world.
Isn't there a way to solve this? Why get rid of the whole procedure, I
like it.

Or maybe just lose the part where you can choose to delete all the
flagged messages.

Marco

Click to expand...

Click to expand...

vonclausowitz · Oct 27, 2005

Eric,

Are you sure the code will work?
I ruled out the CdoPR_FLAG_ICON because my older version of Outlook
doesn't recognize it. So I used: CdoPR_FLAG_STATUS.
If the message is flagged, then delete it....
Because my outlook knows only white or red for flagging I used
objField.Value = 1 (for white).

SetFlag objFoundItem

Private Sub SetFlag(OutlookItemObj As Object)
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

Or do you think I can use the CdoPR_FLAG_ICON?

Marco

Guest · Oct 27, 2005

Yeah, to support all Outlook versions or if you just want to use the default
red flags, use CDOPR_FLAG_STATUS.

vonclausowitz · Oct 27, 2005

If so, then why do I get an error on my office computer when I run
this:

"FlagColour As OlFlagIcon"

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

Regards
Marco

compare two email folders and delete dubble items?

vonclausowitz

Guest

vonclausowitz

Guest

vonclausowitz

Guest

vonclausowitz

Guest

vonclausowitz

Guest

vonclausowitz

vonclausowitz

Guest

vonclausowitz

Guest

vonclausowitz