Consulting

Page 1 of 2 1 2 LastLast
Results 1 to 20 of 25

Thread: Delete older emails with same subject line

  1. #1
    Administrator
    VP-Knowledge Base
    VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location

    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.

  2. #2
    Knowledge Base Approver VBAX Expert brettdj's Avatar
    Joined
    May 2004
    Location
    Melbourne
    Posts
    649
    Location
    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
    Last edited by Aussiebear; 04-04-2023 at 01:03 AM. Reason: Adjusted the code tags

  3. #3
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    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
    Last edited by Aussiebear; 04-04-2023 at 01:06 AM. Reason: Adjusted the code tags

  4. #4
    Knowledge Base Approver VBAX Expert brettdj's Avatar
    Joined
    May 2004
    Location
    Melbourne
    Posts
    649
    Location
    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
    as the inbox may contain meeting requests, voicemail etc

    Cheers

    Dave
    Last edited by Aussiebear; 04-04-2023 at 01:06 AM. Reason: Adjusted the code tags

  5. #5
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    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

  6. #6
    VBAX Mentor
    Joined
    Sep 2004
    Location
    Nashua, NH, USA
    Posts
    489
    Location
    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
    Last edited by Aussiebear; 04-04-2023 at 01:11 AM. Reason: Adjusted the code tags

  7. #7
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    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
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  8. #8
    VBAX Regular
    Joined
    Aug 2005
    Posts
    42
    Location
    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
    Our Greatest Glory is not in never falling, but in rising every time we fall

    There is great satisfaction in building good tools for others to use

  9. #9
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  10. #10
    VBAX Regular
    Joined
    Aug 2005
    Posts
    42
    Location
    Quote Originally Posted by mdmackillop

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

    Set olsession = New Outlook.Application

    Thanks
    Last edited by Aussiebear; 04-04-2023 at 01:12 AM. Reason: Adjusted the code tags
    Our Greatest Glory is not in never falling, but in rising every time we fall

    There is great satisfaction in building good tools for others to use

  11. #11
    VBAX Regular
    Joined
    Aug 2005
    Posts
    42
    Location
    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
    Our Greatest Glory is not in never falling, but in rising every time we fall

    There is great satisfaction in building good tools for others to use

  12. #12
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    See what happens when I don't use Option Explicit!
    Should be
    Dim MS, MySubs 
        MySubs = Array("EE", "VBA")
    I had two sub-folders within "Inbox", EE & VBA.
    Last edited by Aussiebear; 04-04-2023 at 01:12 AM. Reason: Adjusted the code tags
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  13. #13
    VBAX Regular
    Joined
    Aug 2005
    Posts
    42
    Location
    MD, Excellent!!

    Thanks
    Our Greatest Glory is not in never falling, but in rising every time we fall

    There is great satisfaction in building good tools for others to use

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

    I have outlook 2000, any thoughts.

  15. #15
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    Hi Skasu,
    Welcome to VBAX
    Did you notice this line?
    Regards
    MD
    [vba] 'Needs a reference to Microsoft Scripting Runtime[/vba]
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  16. #16
    VBAX Regular
    Joined
    Dec 2007
    Posts
    78
    Location
    Quote Originally Posted by mdmackillop
    Hi Skasu,
    Welcome to VBAX
    Did you notice this line?
    Regards
    MD
     '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?
    Last edited by Aussiebear; 04-04-2023 at 01:13 AM. Reason: Adjusted the code tags

    I think in hindsight the problem was in my coding.

  17. #17
    VBAX Regular
    Joined
    Dec 2007
    Posts
    78
    Location
    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

    I think in hindsight the problem was in my coding.

  18. #18
    VBAX Regular
    Joined
    Dec 2007
    Posts
    78
    Location
    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

    I think in hindsight the problem was in my coding.

  19. #19
    VBAX Regular
    Joined
    Dec 2007
    Posts
    78
    Location
    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?

    I think in hindsight the problem was in my coding.

  20. #20
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    Hi Asterix,
    Post your question in the Outlook forum for a quicker result
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •