Microsoft Office Forums - View Single Post - [Solved] Change category of a message if received again as forward

gmayor · 02-15-2017, 03:28 AM

This is easier said than done as there is no correlation between the two messages.

They will presumably have the same original subject in the body text and they may have the same time of sending of the original message and they should have the same original sender, but there are many areas where this could go wrong and either no message is flagged or the wrong message is flagged.

The following may work, but much depends on how your mail system is configured and what is actually in the messages, but if not you may be able to alter it to suit.

It assumes that the messages sent directly to you, and are to be categorised, are in the default Inbox. I have included a test macro to test the premise with a message received from your manager that also exists in your inbox. If it works run the main script from a rule that identifies messages from your manager.

Code:

Option Explicit

Sub Test()
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    FlagMessage olMsg
lbl_Exit:
    Exit Sub
End Sub

Sub FlagMessage(olItem As MailItem)
Dim strName As String
Dim strSubject As String
Dim strTime As String
Dim vItem As Variant
Dim vText As Variant
Dim vSubject As Variant
Dim i As Long
Dim olFolder As Folder
Dim olItems As Items
Dim olMsg As MailItem
    With olItem
        If LCase(.Subject) = "for examination" Then
            vText = Split(olItem.Body, Chr(13))
            For i = 0 To UBound(vText)
                If InStr(1, vText(i), "From: ") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    strName = LCase(Trim(vItem(1)))
                    strName = Replace(strName, " [mailto", "")
                    Exit For
                End If
            Next i
            For i = 0 To UBound(vText)
                If InStr(1, vText(i), "Sent: ") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    strTime = Trim(vItem(1)) & Chr(58) & vItem(2)
                    Exit For
                End If
            Next i
            For i = 0 To UBound(vText)
                If InStr(1, vText(i), "Subject: ") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    strSubject = LCase(Trim(vItem(UBound(vItem))))
                    Exit For
                End If
            Next i
            Set olFolder = Session.GetDefaultFolder(olFolderInbox)    'the folder where the messages are stored
            Set olItems = olFolder.Items
            olItems.Sort "[Received]", True
            For i = 1 To olItems.Count
                Set olMsg = olItems(i)
                If Format(olMsg.ReceivedTime, "dd mmmm yyyy HH:MM") = strTime Then
                    vSubject = Split(LCase(olMsg.Subject), Chr(58))
                    If strSubject = Trim(LCase(vSubject(UBound(vSubject)))) And _
                       strName = LCase(olMsg.Sender.Name) Then
                        olMsg.Categories = "Worked"
                        olMsg.Save
                        Exit For
                    End If
                End If
            Next i
        End If
    End With
lbl_Exit:
    Set olFolder = Nothing
    Set olItems = Nothing
    Set olMsg = Nothing
    Exit Sub
End Sub