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