OUTLOOK - BulkSatedSubjectMod.vba

BulkDatedSubjectMod.vba

'This will search the beginning of your email messages for the 
' current year(you specify).  If it is not already there, the 
' script will add the current date / time to the beginning of
' your message subject.  Good for archiving messages by date / time

Public Sub datemod()
Dim oMailS As Outlook.MailItem
Dim MsgCount, MsgMatch, ErrCount As Integer
Dim ErrrMsg As String
Dim sstring, dstring


' ------------------------------------------------------------
Set oMailS = Application.ActiveExplorer.Selection(1)
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = Application.ActiveExplorer.CurrentFolder.Items
Set colItems = objFolder

' ------------------------------------------------------------
ErrrMsg = ""
MsgCount = 0 ' Count processed e-mails
MsgMatch = 0 ' Targets matched
ErrCount = 0
msgLines = ""

' ------------------------------------------------------------
On Error GoTo errorHandler 'If there are any errors - SQUAWK!
' ------------------------------------------------------------

For Each objMessage In colItems 'For every message in the inbox

dstring = objMessage.Subject
'Modify this to search for a specific amount of characters at the left, mid or right of the dstring
Subjcheck = Left(dstring, 2)
'Specify the year
If Subjcheck <> "18" Then

   RECEIVED = Format(objMessage.ReceivedTime, "yyMMddHHMMSS")
   'TDSNOW = Format(DateTime.Now, "yyMMddhhmmss")
   dstring = RECEIVED + " " + dstring
    objMessage.Subject = dstring
'   objMessage.Subject = Right(dstring, TL - 13)
   objMessage.Save                                    ' Save the modified message
    
End If


'dstring = ""
'objMessage.Subject = ""
Subjcheck = ""
RECEIVED = ""

Next 'For Each objMessage In colItems

' ------- Clear all script variables ------

Set objOutlook = Nothing 'Clean things up
Set objNameSpace = Nothing 'Clean things up
Set objFolder = Nothing 'Clean things up
Set colItems = Nothing 'Clean things up
Set oMailS = Nothing

ErrrMsg = ""
MsgCount = 0 ' Count processed e-mails
MsgMatch = 0 ' Targets matched
ErrCount = 0
msgLines = ""
dstring = ""
Subjcheck = ""

Exit Sub 'Dishes are DONE MAN!

' ------------ Error-handling routine.
errorHandler:
    
    ' ------------ Add current error to our error log string
    ErrrMsg = ErrrMsg & Date & " - Error: " & Error(Err) & " for message: " & objMessage.Subject & vbNewLine
    ' ------------ increment our error count
    ErrCount = ErrCount + 1
    Resume Next 'Go back to after where the error occurred

End Sub