Microsoft Outlook Script needed or a programmable email client

Hi, Nicotine1.

I think I can solve this for you, but before I write the code I want to make sure the what I have in mind is acceptable.  The approach I have in mind is to use an Outlook task.  When you start Outlook, the script would create the task and set a reminder time.  If a message from the right person with the right subject doesn't arrive before the task's reminder time, then you'll get a reminder telling you that you haven't received a message from the designated sender, with the designated subject, in the designated amount of time.  If a message from that sender with that subject arrives, then the script updates the task by changing the reminder time.  For example, say that you started Outlook at exactly 9:00am.  You've set the script to watch for a message from John.Doe@company.com with a subject of "Project X" and to let you know if you haven't received one in 60 minutes.  If no such message arrives before 10:00am, then you'll get the reminder.  But, if one of these messages comes in at 9:25am, then the script will update the task and change the reminder time to 10:25am (i.e. 60 minutes from the arrival of the last matching message).  So long as another message arrives before each reminder time, then you'll never see a reminder.  You'd only see one if a matching message fails to arrive before the next interval (e.g. 60 minutes) ends.

If that's what you have in mind, then I'll put the code together along with instructions.  If that's not what you want, then please clarify and I'll let you know if I can help out or not.

Yes, this is what I am looking for :)

can it be a flexible subject?  for example subject starts with "Project X  " followed by any text.

Yes, that's doable.

Nicotine1,

Here's the solution I propose.  Here's how it works.  When you start Outlook, the code will create a task for each timer you've set.  Each task's reminder is set according to the parameters you passed in the code.  If a message arrives from the designated sender with the designated subject, then the code will update the task and push the reminder into the future.  If instead you do not get a message from the designated sender with the designated subject within the designated time, then the task's reminder will fire.  The code will display a dialog-box alerting you.  Once you've closed that dialog-box, you can act on the reminder as you would any other reminder (e.g. cancel it, sleep it).  When you close Outlook, the code will remove the tasks.  DO NOT delete the tasks while the code is running.  That will cause an error.  

I've tested the code, but only in a cursory fashion.  You should test it more thoroughly in your environment before depending on it.

The solution comes in three parts.

Part 1.

Follow these instructions to add this code to Outlook.

1.  Start Outlook
2.  Press ALT+F11 to open the Visual Basic Editor
3.  If not already expanded, expand Microsoft Office Outlook Objects
4.  Right-click on Class Modules, select Insert -> Class Module
5.  In the Properties panel click on Name and enter clsTrack
6.  Copy the code from the Code Snippet box and paste it into the right-hand pane of Outlook's VB Editor window
7.  Edit the code as needed.  I included comments wherever something needs to or can change
8.  Click the diskette icon on the toolbar to save the changes

Private strSender As String, strSubject As String, intInterval As Integer, strUID As String, strCategory As String

Public Property Get Sender() As String
    Sender = strSender
End Property

Public Property Let Sender(ByVal strValue As String)
    strSender = LCase(strValue)
End Property

Public Property Get Subject() As String
    Subject = strSubject
End Property

Public Property Let Subject(ByVal strValue As String)
    strSubject = strValue
End Property

Public Property Get Interval() As Integer
    Interval = intInterval
End Property

Public Property Let Interval(ByVal intValue As Integer)
    intInterval = intValue
End Property

Public Property Get UID() As String
    UID = strUID
End Property

Public Property Let UID(ByVal strValue As String)
    strUID = strValue
End Property

Public Property Get Category() As String
    Category = strCategory
End Property

Public Property Let Category(ByVal strValue As String)
    strCategory = strValue
End Property

Public Sub UpdateTask()
    Dim olkTsk As Outlook.TaskItem, datTmp As Date, olkPrp As Outlook.UserProperty
    Set olkTsk = Session.GetDefaultFolder(olFolderTasks).Items.Find("[Subject] = 'Tracker " & strUID & "'")
    If TypeName(olkTsk) = "Nothing" Then
        Set olkTsk = Application.CreateItem(olTaskItem)
        olkTsk.Subject = "Tracker " & strUID
        olkTsk.Categories = strCategory
        Set olkPrp = olkTsk.UserProperties.Add("UID", olText)
        olkPrp.value = strUID
    End If
    datTmp = DateAdd("n", intInterval, Now)
    olkTsk.DueDate = datTmp
    olkTsk.ReminderTime = datTmp
    olkTsk.ReminderSet = True
    olkTsk.Save
    Set olkTsk = Nothing
End Sub

Private Sub Class_Terminate()
    Dim olkTsk As Outlook.TaskItem
    Set olkTsk = Session.GetDefaultFolder(olFolderTasks).Items.Find("[Subject] = 'Tracker " & strUID & "'")
    If TypeName(olkTsk) <> "Nothing" Then
        olkTsk.Delete
    End If
    Set olkTsk = Nothing
End Sub

Select allOpen in new window

Part 2.

Follow these instructions to add this code to Outlook.

1.  Right-click on Class Modules, select Insert -> Class Module
2.  In the Properties panel click on Name and enter clsTracker
3.  Copy the code from the Code Snippet box and paste it into the right-hand pane of Outlook's VB Editor window
4.  Edit the code as needed.  I included comments wherever something needs to or can change
5.  Click the diskette icon on the toolbar to save the changes

Const TRACKER_CAT = "Tracker"

Private WithEvents olkApp As Outlook.Application
Private WithEvents olkRem As Outlook.Reminders
Private colTracks As Collection, intVer As Integer

Private Sub Class_Initialize()
    intVer = GetOutlookVersion()
    Set colTracks = New Collection
    Set olkApp = Outlook.Application
    Set olkRem = olkApp.Reminders
End Sub

Private Sub Class_Terminate()
    Dim objTrack As clsTrack
    Set olkRem = Nothing
    Set olkApp = Nothing
    Set colTracks = Nothing
End Sub

Private Sub olkApp_NewMailEx(ByVal EntryIDCollection As String)
    Dim arrIDS As Variant, varEID As Variant, olkItm As Outlook.MailItem, objTrack As clsTrack, intPos As Integer, strSub As String
    arrIDS = Split(EntryIDCollection, ",")
    For Each varEID In arrIDS
        Set olkItm = Session.GetItemFromID(varEID)
        If olkItm.Class = olMail Then
            For Each objTrack In colTracks
                If LCase(GetSMTPAddress(olkItm, intVer)) = objTrack.Sender Then
                    intPos = InStr(1, objTrack.Subject, "*")
                    If intPos > 0 Then
                        intPos = intPos - 1
                        If Left(olkItm.Subject, intPos) = Left(objTrack.Subject, intPos) Then
                            objTrack.UpdateTask
                        End If
                    Else
                        If olkItm.Subject = objTrack.Subject Then
                            objTrack.UpdateTask
                        End If
                    End If
                End If
            Next
        End If
    Next
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function
 
Private Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function
 
Private Function SMTP2007(olkMsg As Outlook.MailItem) As String
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

Private Sub olkRem_ReminderFire(ByVal ReminderObject As Reminder)
    Dim olkTsk As Outlook.TaskItem, objTrack As clsTrack
    If ReminderObject.Item.Categories = TRACKER_CAT Then
        Set olkTsk = ReminderObject.Item
        Set objTrack = colTracks.Item(olkTsk.UserProperties.Item("UID"))
        MsgBox "You have not received a message from " & objTrack.Sender & " with a subject of """ & objTrack.Subject & """ in the last " & objTrack.Interval & " minutes.", vbInformation + vbOKOnly + vbApplicationModal, "Message Not Received"
    End If
    Set olkTsk = Nothing
    Set objTrack = Nothing
End Sub

Public Sub NewTracker(strKey As String, strSender As String, strSubject As String, intInterval As Integer)
    Dim objTrack As clsTrack, bolExists As Boolean, strKey As String
    If colTracks.Count > 0 Then
        For Each objTrack In colTracks
            If (strFrom = objTrack.Sender) And (strSubject = objTrack.Subject) Then
                bolExists = True
                Exit For
            End If
        Next
    End If
    If Not bolExists Then
        Set objTrack = New clsTrack
        With objTrack
            .UID = strKey
            .Category = TRACKER_CAT
            .Sender = strSender
            .Subject = strSubject
            .Interval = intInterval
            .UpdateTask
        End With
        colTracks.Add objTrack, strKey
    End If
    Set objTrack = Nothing
End Sub

Select allOpen in new window

Part 3.

Follow these instructions to add this code to Outlook.

1.  If not already expanded, expand Microsoft Outlook Objects
2.  Double-click on ThisOutlookSession
3.  Copy the code from the Code Snippet box and paste it into the right-hand pane of Outlook's VB Editor window
4.  Edit the code as needed.  I included comments wherever something needs to or can change
5.  Click the diskette icon on the toolbar to save the changes
6.  Close the VB editor
7.  Ensure macros are enabled in Outlook
8.  Close and restart Outlook

Dim objTracker As clsTracker

Private Sub Application_Quit()
    Set objTracker = Nothing
End Sub

Private Sub Application_Startup()
    Set objRcv = New clsTracker
    'Add a line like the next line of code for each sender/subject you want to track.
    'The syntax is: objTracker.NewTracker "Unique ID", "Sender's Address", "Subject", Time-out value in minutes.
    'You can use an asterisk for a wild card in the subject.  If you use a wildcard, the code will match all characters up to the wildcard character.
    objTracker.NewTracker "one", "John.Doe@company.com", "Project X", 60
    objTracker.NewTracker "two", "Sam.Spade@detectives.com", "Maltese *", 120
End Sub

Select allOpen in new window

I have followed your instruction, but cannot get the script working yet.

What happens after you restart Outlook?  Do you see the tasks being created?

No can't see them. What should I do?

Are macros enabled?

Yes it is

Do I have to run the macros by pressing the green arrow?

You can't run the macro.  It runs by itself.  What is macro security set to?

Sorry, have been sick for past couple of days. The macro security is: no security check for macros

Sorry to hear that.  Hope you're feeling better.

We need to know whether the code is working at all.  To do that, please add the following command immediately after line #7 of the code in part #2.  Once you've done, please close and restart Outlook.  Let me know what happens.

Msgbox "Fired"

Select allOpen in new window

The message poped up.

It is saying there is "Run-time error '91':
Object variable or With block variable not set


Line 91 is this line :

    objTracker.NewTracker "one", "John.Doe@company.com", "Project X", 60

Are you sure all the code is in place in the proper modules?

can't find anything wrong.
Is it ok if the scripts are saved under Project1. Does it matter?

Yes, that's where they belong.  So long as they are in the correct modules under Project1.  Parts 1 and 2 should be under Class Modules while Part 3 must be in ThisOutlookSession which is under Microsoft Outlook Objects, which in turn is under Project1.

This is exactly how it is configured, but still not working. Any idea?

I just went back and looked through the code and found an error.  Line #8 of part 3 needs
to be changed from

Set objRcv = New clsTracker

Select allOpen in new window

to

Set objTracker = New clsTracker

Select allOpen in new window

There is a new one:

"Compile Error"
Duplicate declaration in current scope

The debugger highlighed the following in the clsTracker module:
Public Sub NewTracker(strKey As String, strSender As String, strSubject As String, intInterval As Integer)

    Dim objTrack As clsTrack, bolExists As Boolean, strKey As String

Change this line from

Dim objTrack As clsTrack, bolExists As Boolean, strKey As String

Select allOpen in new window

to

Dim objTrack As clsTrack, bolExists As Boolean

Select allOpen in new window

Blue Devil Fan,

Your script is working fine. Thanks, Can the "task" in the "To Do List" trigger a particular "sound" file?

regards,
Nicotine1

So long as the sound file is a .wav file, yes.  Let me know if that's the type of file you have in mind and I'll modify the code accordingly.

It's .wav file. Let's say it's located in "c:\bell.wave"

Add this code to the very top of the code in Part #1.

'On the next line edit the path to the .wav file you want to play
Public Const SOUND_TO_PLAY = "C:\bell.wav"
Public Const SND_ASYNC = &H1

Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _ (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long Public Declare Function MessageBox _
    Lib "User32" Alias "MessageBoxA" _
        (ByVal hWnd As Long, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal wType As Long) _
    As Long

Select allOpen in new window

Insert this line of code immediately after line #90 of the code in Part #2.

sndPlaySound SOUND_TO_PLAY, SND_ASYNC

Select allOpen in new window

That should do it.

when I paste the new codes in part 1 ( clsTrack) a lot of the codes highlighted red.

Thanks
Nick

Hey, Nick.

My mistake.  The first bit of code needs to go in a regular module.  Either create a new module (e.g. Module2) or open an existing module (e.g. Module1) and add that code at the top.

The following codes are red when I paste the code in Module 1:

Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _ (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long Public Declare Function MessageBox _
    Lib "User32" Alias "MessageBoxA" _
        (ByVal hWnd As Long, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal wType As Long) _
    As Long

Did you paste them in at the top?  Does the code really look like that in the module or does it look like what I posted?

it's exactly what you have posted in

https://www.experts-exchange.com/questions/28343780/Microsoft-Outlook-Script-needed-or-a-programmable-email-client.html?anchorAnswerId=39900523#a39900523

and in a new module ( moduel1)

I asked because what you posted in your post is run together.  That would most certainly cause an error.  

Is the code at the top of Module1?  Nothing before it in that module, right?

Yes, it's at the top of Module 1

Can you show me a screen shot of what it looks like, please?

The code is run together.  Let's try this again.

'On the next line edit the path to the .wav file you want to play
Public Const SOUND_TO_PLAY = "C:\bell.wav"
Public Const SND_ASYNC = &H1

Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _ (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long 

Public Declare Function MessageBox _
    Lib "User32" Alias "MessageBoxA" _
        (ByVal hWnd As Long, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal wType As Long) _
    As Long

Select allOpen in new window

The following is now in red:

Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _ (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

BlueDevilFan is good, thank you so much

You're welcome, Nick!

After closing this question, Nick discovered that one of his rules is interfering with this solution.  To fix that, I've re-written the solution to be triggered by a rule rather than triggering automatically each time a new message arrives.  This changes the code in part #2 of the original solution and adds new code to part #3.  Part #1 remains unchanged.  Nick had also asked for the solution to play a sound.  I added that functionality across several posts.  I'm including it here as part #4.

Part #2 Replacement.

Const TRACKER_CAT = "Tracker"

Private WithEvents olkRem As Outlook.Reminders
Private colTracks As Collection, intVer As Integer

Private Sub Class_Initialize()
    intVer = GetOutlookVersion()
    Set colTracks = New Collection
    Set olkRem = Outlook.Application.Reminders
End Sub

Private Sub Class_Terminate()
    Dim objTrack As clsTrack
    Set olkRem = Nothing
    Set colTracks = Nothing
End Sub

Public Sub NewMessage(olkItm As Outlook.MailItem)
    Dim objTrack As clsTrack, intPos As Integer, strSub As String
    For Each objTrack In colTracks
        If LCase(GetSMTPAddress(olkItm, intVer)) = objTrack.Sender Then
            intPos = InStr(1, objTrack.Subject, "*")
            If intPos > 0 Then
                intPos = intPos - 1
                If Left(olkItm.Subject, intPos) = Left(objTrack.Subject, intPos) Then
                    objTrack.UpdateTask
                End If
            Else
                If olkItm.Subject = objTrack.Subject Then
                    objTrack.UpdateTask
                End If
            End If
        End If
    Next
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function
 
Private Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function
 
Private Function SMTP2007(olkMsg As Outlook.MailItem) As String
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

Private Sub olkRem_ReminderFire(ByVal ReminderObject As Reminder)
    Dim olkTsk As Outlook.TaskItem, objTrack As clsTrack
    If ReminderObject.Item.Categories = TRACKER_CAT Then
        Set olkTsk = ReminderObject.Item
        sndPlaySound SOUND_TO_PLAY, SND_ASYNC
        Set objTrack = colTracks.Item(olkTsk.UserProperties.Item("UID"))
        MsgBox "You have not received a message from " & objTrack.Sender & " with a subject of """ & objTrack.Subject & """ in the last " & objTrack.Interval & " minutes.", vbInformation + vbOKOnly + vbApplicationModal, "Message Not Received"
    End If
    Set olkTsk = Nothing
    Set objTrack = Nothing
End Sub

Public Sub NewTracker(strKey As String, strSender As String, strSubject As String, intInterval As Integer)
    Dim objTrack As clsTrack, bolExists As Boolean, strKey As String
    If colTracks.Count > 0 Then
        For Each objTrack In colTracks
            If (strFrom = objTrack.Sender) And (strSubject = objTrack.Subject) Then
                bolExists = True
                Exit For
            End If
        Next
    End If
    If Not bolExists Then
        Set objTrack = New clsTrack
        With objTrack
            .UID = strKey
            .Category = TRACKER_CAT
            .Sender = strSender
            .Subject = strSubject
            .Interval = intInterval
            .UpdateTask
        End With
        colTracks.Add objTrack, strKey
    End If
    Set objTrack = Nothing
End Sub

Select allOpen in new window

Part #3 Addition.

Public Sub TriggerTracker(Item As Outlook.MailItem)
    clsTracker.NewMessage(Item)
End Sub

Select allOpen in new window

Part #4.  This code must go in a new module or must be added to the top of an existing module.  The module cannot be a class module nor the built-in ThisOutlookSession module.

'On the next line edit the path to the .wav file you want to play
Public Const SOUND_TO_PLAY = "C:\bell.wav"
Public Const SND_ASYNC = &H1

Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
    (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

Public Declare Function MessageBox _
    Lib "user32" Alias "MessageBoxA" _
        (ByVal hwnd As Long, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal wType As Long) _
    As Long

Select allOpen in new window

Hi,

I guess I'll have to create a new rule to trigger the script. What options should I choose?

Nick

If you want it to fire for all messages, then don't set a condition.  Set the action to "run a script" and choose TriggerTracker as the script to run.  Make sure this script is the first script in line.

I have created a rule that trigger when mails are received, but it doesn't run again after the first alarm, like your first script.

The first alarm was not trigger at the right time. Can this be fixed?

Can you post a screenshot of the code you have in ThisOutlookSession?