Consulting

Results 1 to 2 of 2

Thread: Outlook: To move earlier emails of same thread to sub-folder

  1. #1
    VBAX Newbie
    Joined
    Jun 2019
    Posts
    1
    Location

    Outlook: To move earlier emails of same thread to sub-folder

    Hi All,

    My requirement is to move earlier emails of same thread to a sub-folder and only the recent/latest email to be in the primary folder.
    That is , when we sort emails by subject and if 5 mails for same subject then except the latest email , rest should be moved to sub-folder.
    And if the new email arrives on same subject to primary folder then the older ones should move to sub-folder. Could you please help me.

    Please suggest. Thanks.

  2. #2
    VBAX Mentor
    Joined
    Dec 2008
    Posts
    404
    Location
    Because Ljame has a problem with editing the post, I put here what I received in PM.
    [QUOTE = Ljame; 392016] I am trying to move all but not the latest email of same thread (subject wise) to a sub folder. The below code does it but upon every loop it gets error "Method 'ReceivedTime' of object '_MailItem' failed” on debug its on line "comparisonItemAge=today - mItem.ReceivedTime.
    So, upon clicking debug and rerun it moves the old email then again gets same error.
    Could you please review and help me to resolve this issue. Thanks. [/ QUOTE]
    Dim nSpace As Outlook.NamespaceDim targetFolder As MAPIFolder
    Dim desFolder As MAPIFolder
    Dim mItem As MailItem
    Dim comparisonItem As MailItem
    Dim tempSubject As String
    Dim today As Date
    
    
    
    
    Private Sub Application_NewMail()
    Set nSpace = GetNamespace("MAPI")
    Set targetFolder = nSpace.Folders("abc@abc.com").Folders("Inbox").Folders("TAR_TEST")
    Set desFolder = nSpace.Folders("abc@abc.com").Folders("Inbox").Folders("DES_TEST")
    
    
    
    
    For Each mItem In targetFolder.Items
    tempSubject = mItem.Subject
        While InStr(1, Left(tempSubject, 3), "RE:") > 0 Or InStr(1, Left(tempSubject, 4), "FW:") > 0
            tempSubject = Mid(tempSubject, 5)
        Wend
    
    
    
    
        For Each comparisonItem In targetFolder.Items
            If InStr(1, comparisonItem.Subject, tempSubject) > 0 Then
                today = Now()
                currentItemAge = today - comparisonItem.ReceivedTime
                comparisonItemAge = today - mItem.ReceivedTime
                If currentItemAge < comparisonItemAge Then
                    mItem.Move desFolder
                    Exit For
                End If
          
                If currentItemAge > comparisonItemAge Then
                    comparisonItem.Move desFolder
                    Exit For
                End If
            End If
        Next
      Next
    
    
    
    
    Set targetFolder = Nothing
    Set desFolder = Nothing
    Set nSpace = Nothing
    End Sub

Posting Permissions

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