Solved: Delete older emails with same subject line

[mdmackillop]

As I receive quite a few emails with the same subject line from VBA Express, is there a macro I can run which will delete all the older messages with duplicate subject lines, leaving only the newest?
MD

PS I have never attempted Outlook macros.

[brettdj]

Hi Malcom

I had a crack at this below, the code moves the older messages into a subfolder called "Old". I'm wary whether the code always moves the correct old message with this line
olInbox.Items(olItem.Subject).Move olDupe

In my testing it worked but.....

The code uses a Dictionary Object to hold the subject name and sender (so it wont cull messages from different senders with the same subject). I've used early binding so you need to set a reference to Microsoft Scripting Runtime.

I think that the Find method would be a superior way of doing this speedwise, I'll have a play


Cheers

Dave

Sub KillDupes() 
     'Needs a reference to Microsoft Scripting Runtime
    Dim olSession As Outlook.Application, olNamespace As NameSpace 
    Dim olInbox As Outlook.MAPIFolder, olDupe As Outlook.MAPIFolder 
    Dim olItem As MailItem 
    Dim olDict As Dictionary 
    Set olSession = New Outlook.Application 
    Set olDict = New Scripting.Dictionary 
    Set olNamespace = olSession.GetNamespace("MAPI") 
    Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox) 
    On Error Resume Next 
    Set olDupe = olInbox.Folders("Old") 
    If Err <> 0 Then Set olDupe = olInbox.Folders.Add("Old") 
    On Error Goto 0 
     
    For Each olItem In olInbox.Items 
        If TypeName(olItem) = "MailItem" Then 
            If olDict.Exists(olItem.Subject & olItem.SenderName) Then 
                 'if the subject exists test to see which message is newer
                If olItem.ReceivedTime > olDict(olItem.Subject & olItem.SenderName) Then 
                    olInbox.Items(olItem.Subject).Move olDupe 
                    olDict.Remove olItem.Subject & olItem.SenderName 
                    olDict.Add olItem.Subject & olItem.SenderName, olItem.ReceivedTime 
                Else 
                     ' move the current item if it is older
                    olItem.Move olDupe 
                End If 
            Else 
                olDict.Add olItem.Subject & olItem.SenderName, olItem.ReceivedTime 
            End If 
        End If 
    Next 
    Set olDict = Nothing 
    Set olSession = Nothing 
End Sub 

VBA tags courtesy of www.thecodenet.com

[mdmackillop]

Thanks Dave,
It works a treat on Inbox, but I commonly have one level of sub-folder within inbox so I've tweaked your code to the following:

 
Sub KillDupes() 
     'Needs a reference to Microsoft Scripting Runtime
    Dim olSession As Outlook.Application, olNamespace As NameSpace 
    Dim olInbox As Outlook.MAPIFolder, olDupe As Outlook.MAPIFolder 
    Dim MyolInbox As Outlook.MAPIFolder 
    Dim olItem As MailItem 
    Dim olDict As Dictionary 
    Dim MS 
    MySubs = Array("EE", "VBA") 
     
    Set olSession = New Outlook.Application 
    Set olDict = New Scripting.Dictionary 
    Set olNamespace = olSession.GetNamespace("MAPI") 
    Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox) 
     
    For Each MS In MySubs 
        Set MyolInbox = olInbox.Folders(MS) 
         
        On Error Resume Next 
        Set olDupe = olInbox.Folders("Old") 
        If Err <> 0 Then Set olDupe = olInbox.Folders.Add("Old") 
        On Error Goto 0 
        For Each olItem In MyolInbox.Items 
            If TypeName(olItem) = "MailItem" Then 
                If olDict.Exists(olItem.Subject & olItem.SenderName) Then 
                     'if the subject exists test to see which message is newer
                    If olItem.ReceivedTime > olDict(olItem.Subject & olItem.SenderName) Then 
                        MyolInbox.Items(olItem.Subject).Move olDupe 
                        olDict.Remove olItem.Subject & olItem.SenderName 
                        olDict.Add olItem.Subject & olItem.SenderName, olItem.ReceivedTime 
                    Else 
                         ' move the current item if it is older
                        olItem.Move olDupe 
                    End If 
                Else 
                    olDict.Add olItem.Subject & olItem.SenderName, olItem.ReceivedTime 
                End If 
            End If 
        Next 
    Next 
    Set olDict = Nothing 
    Set olSession = Nothing 
End Sub 
 

VBA tags courtesy of www.thecodenet.com

[brettdj]

Malcolm,

Did it always move the older message? I'm not sure if the code needs a sort routine or not. Please note this change

Dim olItem As MailItem 
should be 
Dim olItem As Object 

VBA tags courtesy of www.thecodenet.com

as the inbox may contain meeting requests, voicemail etc

Cheers

Dave

[mdmackillop]

Hi Dave,
It works fine. With the change I made, I only have emails in the two designated folders, but a useful filter anyway.
Thanks
Malcolm

[Howard Kaikow]

This is the second time I've tried posting here.
I guess I pushed the wrong button the first time.

Option Explicit 
Private Sub RemoveDuplicateSubjectSender() 
     'Needs a reference to Microsoft Scripting Runtime
     'Needs a reference to Microsoft Outlook object library if not run in Outlook
    Dim i As Long 
    Dim MyolInbox As Outlook.MAPIFolder 
    Dim olInbox As Outlook.MAPIFolder 
    Dim olNamespace As Outlook.NameSpace 
    Dim olSession As Outlook.Application 
    Dim strMailFolders() As String 
     
    ReDim strMailFolders(1) 
    strMailFolders(0) = "EE" 
    strMailFolders(1) = "VBA" 
     
    Set olSession = New Outlook.Application 
    Set olNamespace = olSession.GetNamespace("MAPI") 
    Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox) 
     
    On Error Resume Next 
    RemoveDuplicates olInbox 
    With olInbox 
        For i = 0 To UBound(strMailFolders) 
            Set MyolInbox = .Folders(strMailFolders(i)) 
            If Err.Number = 0 Then 
                RemoveDuplicates MyolInbox 
            Else 
                Err.Clear 
            End If 
        Next i 
    End With 
     
    olSession.Quit 
    Set MyolInbox = Nothing 
    Set olInbox = Nothing 
    Set olNamespace = Nothing 
    Set olSession = Nothing 
End Sub 
Private Sub RemoveDuplicates(MyolInbox As Outlook.MAPIFolder) 
    Dim olDict As Scripting.Dictionary 
    Dim olDupe As Outlook.MAPIFolder 
     ' Dim olItem As Outlook.MailItem
    Dim olItem As Object 
    Dim strSubjectSender As String 
     
    Set olDict = New Scripting.Dictionary 
    On Error Resume Next 
    Set olDupe = MyolInbox.Folders("Old") 
    With Err 
        If .Number <> 0 Then 
            Set olDupe = MyolInbox.Folders.Add("Old") 
            .Clear 
        End If 
    End With 
    For Each olItem In MyolInbox.Items 
        With olItem 
            strSubjectSender = .Subject & .SenderName 
            If TypeName(olItem) = "MailItem" Then 
                If olDict.Exists(strSubjectSender) Then 
                     'if the subject exists test to see which message is newer
                    If .ReceivedTime > olDict(strSubjectSender) Then 
                        MyolInbox.Items(.Subject).Move olDupe 
                        olDict.Remove strSubjectSender 
                        olDict.Add strSubjectSender, .ReceivedTime 
                    Else 
                         ' move the current item if it is older
                        .Move olDupe 
                    End If 
                Else 
                    olDict.Add strSubjectSender, .ReceivedTime 
                End If 
            End If 
        End With 
    Next 
    Set olDict = Nothing 
    Set olDupe = Nothing 
    Set olItem = Nothing 
End Sub 

VBA tags courtesy of www.thecodenet.com

[mdmackillop]

Hi Howard,
I saw your earlier posting, now superceded by this one. I think you should reinstate your comments as to what this revised coding does.
MD

[francis]

Hi MD

Using the above cause Outlook to prompt a security msg stating that a program is trying to gain access to the address book, is there a way to do
away this security msg.

Thanks

[mdmackillop]

I don't believe so
http://www.vbaexpress.com/forum/showthread.php?t=7847

[francis]

Quote:   Originally Posted by: mdmackillop I don't believe so http://www.vbaexpress.com/forum/showthread.php?t=7847

I have a look at the link provided, and removing New Outlook works in

Set olsession = New Outlook.Application 

VBA tags courtesy of www.thecodenet.com

Thanks

[francis]

Hi MD,

Error msg ' Variables not defined ' appear for this line when I run your marco for a another layer of sub folder.

Dim MS 
My Subs = Array ("EE", "VBA") 

VBA tags courtesy of www.thecodenet.com

Would appreciate your guide on this line

Thanks

[mdmackillop]

See what happens when I don't use Option Explicit!
Should be

Dim MS, MySubs 
MySubs = Array("EE", "VBA") 

VBA tags courtesy of www.thecodenet.com

I had two sub-folders within "Inbox", EE & VBA.

[francis]

MD, Excellent!!

Thanks

[skasu123]

Hi, I got compile error on line
Dim olDict As Dictionary
Error is 'User-defined type not defined'.

I have outlook 2000, any thoughts.

[mdmackillop]

Hi Skasu,
Welcome to VBAX
Did you notice this line?
Regards
MD

 'Needs a reference to Microsoft Scripting Runtime

VBA tags courtesy of www.thecodenet.com

[Asterix]

Quote:   Originally Posted by: mdmackillop Hi Skasu, Welcome to VBAX Did you notice this line? Regards MD 'Needs a reference to Microsoft Scripting Runtime VBA tags courtesy of www.thecodenet.com

I have tried to search Outlooks own help and I'll go on Google after I've posted this, but...obvious Noobie here...what is "Microsoft Scripting Runtime", how do you create a reference to it and what is the effect?

[Asterix]

Quote:   Originally Posted by: Asterix I have tried to search Outlooks own help and I'll go on Google after I've posted this, but...obvious Noobie here...what is "Microsoft Scripting Runtime", how do you create a reference to it and what is the effect?

Own question answered, GIMF... http://msdn.microsoft.com/en-us/library/aa164509(office.10).aspx

[Asterix]

Ok, this code works but in my case, I'm not looking to remove older emails in *my* inbox. I'm looking to remove older emails in a group mailbox which I can see like this...
[quote]
Mailbox - Thegaul, Asterix

[Asterix]

Code works fine but in my case I'm looking to remove older emails from a shared groupbox, displayed like this...

- Mailbox - Thegaul, Asterix
Archive
Deleted Items
Drafts
Inbox
Junk E-mail
Outbox
Sent Items
Search Folders
- Mailbox - Groupbox, Our
Deleted Items
Inbox
Outbox
Sent Items
Search Folders

It's the "- Mailbox - Groupbox, Our", "Inbox" that I want to remove the older emails from. Any idea how I can modify this code to do this?

[mdmackillop]

Hi Asterix,
Post your question in the Outlook forum for a quicker result