Delete older emails with same subject line

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. :bink:

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

Code:

---

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

---

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:

Code:

---


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

---

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

Code:

---

Dim olItem As MailItem
should be
Dim olItem As Object

---

as the inbox may contain meeting requests, voicemail etc

Cheers

Dave

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

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

Code:

---

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

---

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

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

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

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

Code:

---

Set olsession = New Outlook.Application

---

Thanks :yes

Hi MD,

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

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

Would appreciate your guide on this line

Thanks

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

Code:

---

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

---

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

MD, Excellent!!

Thanks

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

I have outlook 2000, any thoughts.

Hi Skasu,
Welcome to VBAX
Did you notice this line?
Regards
MD
[vba] 'Needs a reference to Microsoft Scripting Runtime[/vba]

Quote:

---

Originally Posted by mdmackillop

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

Code:

---

'Needs a reference to Microsoft Scripting Runtime

---

---

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?

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/libr...ffice.10).aspx

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

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?

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

Quote:

---

Originally Posted by mdmackillop

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

---

Cheers m8e, but what am I missing? As, when I check, this thread *is* in the Outlook Help forum.

Quote:

---

Originally Posted by 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

[vba]
Dim olItem As MailItem
should be
Dim olItem As Object
[/vba]

as the inbox may contain meeting requests, voicemail etc

Cheers

Dave

---

Hi Dave,

I am new to macros so please bear with my lack of knowledge on the subject. The code is great and is exactly what I need for a makeshift inventory system I have set up for my small business utilizing QR codes and a smart phone to email the information. Sometimes the code works perfectly but sometimes the newer message is moved to the "old" folder. Any suggestions on how to fix this would be greatly appreciated.

Thank you very much,

Gene

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

an erro "olDict As Scripting.Dictionary“ user type not define

Quote:

---

user type not define

---

add a reference to microsoft scripting runtime