Outlook "Run Script" rule not triggering VBA script for incoming messages

Question

I am creating this new topic on the advice of another member. For additional history regarding how things arrived at this point see this question.

I have this VBA script, that I know works if it gets triggered. If I use the TestLaunch subroutine with a message already in my inbox that meets the rule criteria (but, of course, isn't being kicked off by the rule) it activates the link I want it to activate flawlessly. If, when I create the rule I say to apply it to all existing messages in my inbox, it works flawlessly. However, where it's needed, when new messages arrive it does not.

I know that the script is not being triggered because if I have a rule like this:

Outlook "New Message" rule that has "play sound" enabled

with "Play a sound" as part of it, the sound always plays when a message arrives from either of the two specified senders, so the rule is being triggered. I have removed the sound playing part from the rule, and integrated it into the VBA code for testing purposes instead:

Option Explicit

Private Declare Function ShellExecute _
  Lib "shell32.dll" Alias "ShellExecuteA" ( _
  ByVal hWnd As Long, _
  ByVal Operation As String, _
  ByVal Filename As String, _
  Optional ByVal Parameters As String, _
  Optional ByVal Directory As String, _
  Optional ByVal WindowStyle As Long = vbMinimizedFocus _
  ) As Long

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

Sub PlayTheSound(ByVal WhatSound As String)
    If Dir(WhatSound, vbNormal) = "" Then
        ' WhatSound is not a file. Get the file named by
        ' WhatSound from the Windows\Media directory.
        WhatSound = Environ("SystemRoot") & "\Media\" & WhatSound
        If InStr(1, WhatSound, ".") = 0 Then
            ' if WhatSound does not have a .wav extension,
            ' add one.
            WhatSound = WhatSound & ".wav"
        End If
        If Dir(WhatSound, vbNormal) = vbNullString Then
            Beep            ' Can't find the file. Do a simple Beep.
            Exit Sub
        End If
    Else
        ' WhatSound is a file. Use it.
    End If

    sndPlaySound32 WhatSound, 0&    ' Finally, play the sound.
End Sub

Public Sub OpenLinksMessage(olMail As Outlook.MailItem)

 Dim Reg1 As RegExp
 Dim AllMatches As MatchCollection
 Dim M As Match
 Dim strURL As String
 Dim RetCode As Long

Set Reg1 = New RegExp

With Reg1
 .Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
 .Global = True
 .IgnoreCase = True
End With

PlayTheSound "chimes.wav"

' If the regular expression test for URLs in the message body finds one or more
If Reg1.test(olMail.Body) Then

'      Use the RegEx to return all instances that match it to the AllMatches group
       Set AllMatches = Reg1.Execute(olMail.Body)
       For Each M In AllMatches
               strURL = M.SubMatches(0)
'              Don't activate any URLs that are for unsubscribing; skip them
               If InStr(1, strURL, "unsubscribe") Then GoTo NextURL
'              If the URL ends with a > from being enclosed in darts, strip that > off
               If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)
'              The URL to activate to accept must contain both of the substrings in the IF statement
               If InStr(1, strURL, ".com") Then
                     PlayTheSound "TrainWhistle.wav"
'                    Activate that link to accept the job
                     RetCode = ShellExecute(0, "Open", "http://nytimes.com")
                     Set Reg1 = Nothing
                     Exit Sub
               End If

NextURL:
   Next

End If

Set Reg1 = Nothing

End Sub

Private Sub TestLaunchURL()
    Dim currItem As MailItem
    Set currItem = ActiveExplorer.Selection(1)
    OpenLinksMessage currItem
End Sub

which should play "chimes.wav" if the VBA script is triggered in all cases and play "TrainWhistle.wav" if my actual link activation processing occurs. When new messages arrive, neither happens, yet if there is a "Play sound" on the Outlook rule that should run this script that sound gets played.

At the moment I have the Trust Center settings for macros to allow all, as Outlook was being cranky about signing that used selfcert.exe earlier in the testing process. I would really like to be able to elevate the macro protections again rather than leave them at "run all" when this is all done.

But, first and foremost, I cannot for the life of me figure out why this script will run perfectly via the debugger or if applied to existing messages, but is not triggered by the very same Outlook rule applied to existing messages when an actual new message arrives. This is true under Outlook 2010, where I'm developing this script, and also under Outlook 2016, on a friend's machine where it's being deployed.

Any guidance on resolving this issue would be most appreciated.

From the thoughts expressed in this and previous questions it is possible you are not aware there is a "run a script" option in the rules wizard where you would choose OpenLinksMessage. — niton
Uh, no. I didn't think that this was not entirely obvious from my extended discussion of the rule in the text and title. The issue is that "run script" in the rule is not, in fact, running the script even when the message meets the rule criteria that should cause it to be run. Let's not get into the screen shot I gave of the rule that shows "run a script." — britechguy
Does other run a script code work for incoming messages? Something simple like MsgBox oMail.SenderEmailAddress as the only line of code. Run on all incoming messages, no address criteria in the rule. — niton
I created a public subroutine that does the simple message box as you directed and set it in a rule that has no filtering criteria and is applied to each incoming message. It does run and I get the message box popping up. — britechguy
The last step then is to replace OpenLinksMessage in the rule with this Msgbox code to confirm the address criteria is valid. — niton

britechguy britechguy · Accepted Answer · 2017-08-15T04:18:19

Here is the code that finally works. It's clear that the .Body member of olMail is not available until some sort of behind the scenes processing has had time to occur and if you don't wait long enough it won't be there when you go to test using it. Focus on the Public Sub OpenLinksMessage

The major change that allowed that processing to take place, apparently, was the addition of the line of code: Set InspectMail = olMail.GetInspector.CurrentItem. The time it takes for this set statement to run allows the .Body to become available on the olMail parameter that's passed in by the Outlook rule. What's interesting is that if you immediately display InspectMail.Body after the set statement it shows as empty, just like olMail.Body used to.

Option Explicit

Private Declare Function ShellExecute _
  Lib "shell32.dll" Alias "ShellExecuteA" ( _
  ByVal hWnd As Long, _
  ByVal Operation As String, _
  ByVal Filename As String, _
  Optional ByVal Parameters As String, _
  Optional ByVal Directory As String, _
  Optional ByVal WindowStyle As Long = vbMinimizedFocus _
  ) As Long



Public Sub OpenLinksMessage(olMail As Outlook.MailItem)

 Dim InspectMail As Outlook.MailItem
 Dim Reg1 As RegExp
 Dim AllMatches As MatchCollection
 Dim M As Match
 Dim strURL As String
 Dim SnaggedBody As String
 Dim RetCode As Long

' The purpose of the following Set statement is strictly to "burn time" so that the .Body member of
' olMail is available by the time it is needed below.  Without this statement the .Body is consistently
' showing up as empty.  What's interesting is if you use MsgBox to display InspectMail.Body immediately after
' this Set statement it shows as empty.
Set InspectMail = olMail.GetInspector.CurrentItem

Set Reg1 = New RegExp

With Reg1
 .Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
 .Global = True
 .IgnoreCase = True
End With

RetCode = Reg1.Test(olMail.Body)
' If the regular expression test for URLs in the message body finds one or more
If RetCode Then
'      Use the RegEx to return all instances that match it to the AllMatches group
       Set AllMatches = Reg1.Execute(olMail.Body)
       For Each M In AllMatches
               strURL = M.SubMatches(0)
'              Don't activate any URLs that are for unsubscribing; skip them
               If InStr(1, strURL, "unsubscribe") Then GoTo NextURL
'              If the URL ends with a > from being enclosed in darts, strip that > off
               If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)
'              The URL to activate to accept must contain both of the substrings in the IF statement
               If InStr(1, strURL, ".com") Then
'                    Activate that link to accept the job
                     RetCode = ShellExecute(0, "Open", strURL)
                     Set InspectMail = Nothing
                     Set Reg1 = Nothing
                     Set AllMatches = Nothing
                     Set M = Nothing
                     Exit Sub
               End If

NextURL:
   Next

End If

Set InspectMail = Nothing
Set Reg1 = Nothing
Set AllMatches = Nothing
Set M = Nothing

End Sub

Special thanks to niton for his patience and assistance.

Outlook "Run Script" rule not triggering VBA script for incoming messages

1 Answers