Microsoft Office Forums - View Single Post

gmayor · 08-12-2015, 10:27 PM

It should be possible provided you can identify the messages you want to tag with a rule to process them as they arrive. The following macros store the incremented tag number in the registry (so the count is only maintained on one PC). The process them checks to establish if the last word in the subject of the message is a tag in the format - 2015DR00001 (where the first four digits are the year and the last 5 the incrementing number). If the message is not a reply with 'RE:' at the start of the subject the tag is added to the end of the subject.

Put the code in a new Outlook VBA module and run the script 'AddTag' from the rule.

I have included a macro to test the code on an existing message and another to remove the registry entry to reset the count after testing.

Code:

Option Explicit

Sub TestProcess()
'Graham Mayor www.gmayor.com
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    AddTag olMsg
lbl_Exit:
    Exit Sub
End Sub

Sub AddTag(olItem As Outlook.MailItem)
'Graham Mayor www.gmayor.com
    If Not TagExists(olItem.Subject) Then
        olItem.Subject = olItem.Subject & " - " & Year(Date) & "DR" & AddNumber
        olItem.Save
    End If
lbl_Exit:
    Exit Sub
End Sub

Private Function TagExists(strSubject As String) As Boolean
'Graham Mayor www.gmayor.com
    If Not Left(strSubject, 3) = "RE:" Then
        strSubject = Mid(strSubject, InStrRev(strSubject, Chr(32)))
        If IsNumeric(Left(strSubject, 4)) And _
           IsNumeric(Right(strSubject, 5)) And _
           InStr(5, strSubject, "DR") > 0 Then
            TagExists = True
        End If
    End If
lbl_Exit:
    Exit Function
End Function

Private Function AddNumber() As String
'Graham Mayor www.gmayor.com
Dim TagNum As Long
    TagNum = GetSetting(appname:="E-Mail Tag", section:="Config", _
                        Key:="TagNumber", Default:="0")
    TagNum = TagNum + 1
    SaveSetting appname:="E-Mail Tag", section:="Config", _
                Key:="TagNumber", setting:=TagNum
    AddNumber = Format(TagNum, "00000")
lbl_Exit:
    Exit Function
End Function

Sub ResetNumbering()
'Graham Mayor www.gmayor.com
    DeleteSetting "E-Mail Tag"
lbl_Exit:
    Exit Sub
End Sub