Deleting Outlook mails

[drkestrel]

I have some "duplicate mails" in my outlook *.pst folder which I want automated deletion.

By duplicates, I mean, two mail items with the same sender, recipients, subject and sent date.

How could I iterate through each item in a mail folder and do deletion

 

[ide]

'***************************************************************************************
It must to create a myMessageT type, because it badly slow if i use the items in comparison with an another mailitem.
Run DeleteDupsInSelectedFolder sub onto the active folder.
Warning: it works if the folder's items are MailItem typed.

Type myMessageT
iTM As MailItem
Vsubject As String
VReceivedTime As Date
VrecipCount As Integer
vSenderName As String
End Type
Sub DeleteDupsInSelectedFolder()
Dim myOlApp, myNameSpace, myFolder As Object
Dim myObjAr0() As myMessageT, myDelAr() As myMessageT
Dim myItem As myMessageT
Dim arrItCnt As Long
Set myFolder = Application.ActiveExplorer.CurrentFolder
ReDim myObjAr0(1): ReDim myDelAr(1)
On Error Resume Next
Call setItem(myObjAr0(1), myFolder.Items(1))
For i = 2 To myFolder.Items.Count 'get activefolder items
Call setItem(myItem, myFolder.Items(i))
arrItCnt = UBound(myObjAr0)
For j = 1 To UBound(myObjAr0) 'arrItCnt 'UBound(myObjAr0) 'search for current item in myObjAr
If (myItem.Vsubject = myObjAr0(j).Vsubject) _
And (myItem.VReceivedTime = myObjAr0(j).VReceivedTime) _
And (myItem.VrecipCount = myObjAr0(j).VrecipCount) _
And (myItem.vSenderName = myObjAr0(j).vSenderName) Then
Call setItem(myDelAr(UBound(myDelAr)), myFolder.Items(i))
ReDim Preserve myDelAr(UBound(myDelAr) + 1) 'select items to delete
End If
Next j
ReDim Preserve myObjAr0(UBound(myObjAr0) + 1)
Call setItem(myObjAr0(i), myFolder.Items(i))
Next i
For i = 1 To UBound(myDelAr) - 1
myDelAr(i).iTM.Delete
Next i
End Sub

Sub setItem(myArr As myMessageT, myItem As MailItem)
Set myArr.iTM = myItem: myArr.VReceivedTime = myArr.iTM.ReceivedTime
myArr.VrecipCount = myArr.iTM.Recipients.Count: myArr.vSenderName = myArr.iTM.SenderName
myArr.Vsubject = myArr.iTM.Subject
End Sub

i hope it helps
ide

 

[ide]

it was an OTM, an Outlook VBA macro

 

[drkestrel]

I tried another approach, trying to use the

Restrict

method, but run into all sorts of problems with the query, which needs to be a String. I highlight the problematic lines in bold

Dim myOutlook As Outlook.Application
Dim ns As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itms As Outlook.Items
Dim itm As Object
Dim firstMail As MailItem
Dim duplicates As Collection

Set olOutlook = CreateObject("Outlook.Application")
Dim firstSender As String
Dim firstDate As Date
Dim firstSubject  As String
Dim firstSize As Long
Dim toField As String
Dim ccField As String
Set ns = olOutlook.GetNamespace("MAPI")

'Let me select which folder to process
Set itms = ns.PickFolder().Items
On Error GoTo errorHandler

For Each firstMail In itms
    firstSender = firstMail.SenderName
    firstDate = firstMail.ReceivedTime
    toField = firstMail.To
    ccField = firstMail.CC
    firstSubject = firstMail.Subject
    firstSize = firstMail.Size
    Dim query As String

query = "[SenderName] =" + Chr(34) + firstSender + Chr(34) + " And [Subject] = " + _
Chr(34) + firstSubject + Chr(34) + " And [Size] =" + CStr(firstSize) + " And " _
+ "[To] =" + Chr(34) + CStr(toField) + Chr(34) + " And [CC] = " _
+ Chr(34) + CStr(ccField) + Chr(34)

    Set duplicates = itms.Restrict(query)
    
    For Each eachDuplicate In duplicates
        eachDuplicate.Delete
        MsgBox "Delete duplicate mail From '" + firstSender + "' size-" + firstSize _
               + " with subject '" + firstSubject + "'"
               
    Next
        
        
    Exit For
Next


errorHandler:
Msg = "Error # " & Str(Err.Number) & " was generated by " _
            & Err.Source & Chr(13) & Err.Description
    MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext

I tried different permutations of quotations, but either get run time error (from the errorHandler) saying type mismatch, or invalid condition or "Method Restrict of object _items failed"

 

[drkestrel]

Strangely, the following piece of code works!

query = "[SenderName]=" & Chr(39) & firstSender & Chr(39) & " And [Subject]=" & _
             Chr(39) & firstSubject & Chr(39) & " And [Size]=" & firstSize
Set firstDuplicate = itms.Find(query)

However the following piece of code resuts in Error #13 Type Mismatch.

query = "[SenderName]=" & Chr(39) & firstSender & Chr(39) & " And [Subject]=" & _
             Chr(39) & firstSubject & Chr(39) & " And [Size]=" & firstSize
Set duplicateCollections = itms.Restrict(query)

and yet, both Find and Restrict are meant to accept the same argument.

The Find method won't work for me, cos I don't know what Find would return when there's no match, in which case calling firstDuplicate.Delete would....