Auto Insert Current Date or Time into Email Subject


Outlook version
Outlook 2019 32-bit
Email Account
Office 365 Exchange
I'm looking to have some VBA code to auto-insert the current date every time I click new email.
I was able to figure out the code to run as a Macro of how I want it to work (adapted from your code :) )but can't figure out how to automate it. Help Please

Sub AddDatetoSubject()
Dim myolApp As Outlook.Application
Dim aItem As MailItem ' Object

Set myolApp = CreateObject("Outlook.Application")
Set mail = myolApp.ActiveExplorer.CurrentFolder

Dim iItemsUpdated As Integer
Dim strTemp As String
Dim strDate As String

iItemsUpdated = 0
For Each aItem In mail.Items
Debug.Print aItem.ConversationTopic
strDate = Format(aItem.ReceivedTime, "yy-mm-dd")
strTemp = strDate & " " & aItem.Subject
aItem.Subject = strTemp
iItemsUpdated = iItemsUpdated + 1
Next aItem

MsgBox iItemsUpdated & " of " & mail.Items.Count & " Messages Updated"
Set myolApp = Nothing
End Sub

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
you need to use activeinstpector. I pulled this from

Are you adding it to the subject or body?

Not tested so it might have a typo or bug or two....

Private WithEvents m_Inspectors As Outlook.Inspectors
Private WithEvents m_Inspector As Outlook.Inspector
Private Sub Application_Startup()
  Set m_Inspectors = Application.Inspectors
End Sub

Private Sub m_Inspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
  Set m_Inspector = Inspector
End Sub

Private Sub m_Inspector_Activate()
' skip calendar and contacts
If m_Inspector.CurrentItem.Class = olAppointment Or m_Inspector.CurrentItem.Class = olContact Then
    Exit Sub

' use this to format or if you want short date format, just use Date where you want the date
 strDate = Format(date, "yy-mm-dd") 

' subject

 m_Inspector.subject =  strDate
'm_Inspector.subject =  Date

' can either use word or a simple .body command to 
' insert in body
Dim olInspector As Outlook.Inspector
Dim olDocument As Word.Document
Dim olSelection As Word.Selection

Set olInspector = Application.ActiveInspector()
Set olDocument = olInspector.WordEditor
Set olSelection = olDocument.Application.Selection

olSelection.InsertBefore strDate
' olSelection.InsertBefore Date
 Set m_Inspector = Nothing
End Sub


Outlook version
Outlook 2019 32-bit
Email Account
Office 365 Exchange
Thanks so much! I almost have the code completed. This is what I have in the ThisOutlookSession code area.
There are two issues I was hoping for any help
1)I want this code to run any time I create a new message. Currently, I have to run the macro and then click new email for it to run. I'd prefer have it run automatically every time I clock new email.
2)I'm hoping that when solving #1, it solves the issue that I have when I open .msg files that we have stored on our local drive, this macro runs. I believe it's running because it runs every time I open a message instead of only on new messages.

Public WithEvents objInspectors As Inspectors
Public WithEvents objMail As MailItem

Public Sub Initialize_handlers()
Set objInspectors = Application.Inspectors
End Sub

Public Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
If TypeOf Inspector.CurrentItem Is MailItem Then
Set objMail = Inspector.CurrentItem
End If
End Sub

Public Sub objMail_Open(Cancel As Boolean)
Dim strDate As String

'the current date

strDate = Format(Date, "yy mm dd")

' MsgBox "user chose " & lstNo & " from combo"

Select Case lstNo
Case -1
objMail.Subject = strDate & " "
Case 0
objMail.Subject = strDate & " West1 "
Case 1
objMail.Subject = strDate & " Charlotte "
Case 2
objMail.Subject = strDate & " "
Case 3
objMail.Subject = "Subject 4"
Case 4
objMail.Subject = "Subject 5"
End Select

End Sub