Outlook“运行脚本"规则不触发传入消息的VBA脚本 [英] Outlook "Run Script" rule not triggering VBA script for incoming messages
问题描述
我正在根据另一位成员的建议创建这个新主题.有关此时如何到达的其他历史记录，请参见此问题.
我有这个VBA脚本，我知道它会被触发 .如果我使用TestLaunch子例程，但收件箱中已有一条符合规则标准的消息(但是，当然还没有被规则启动)，它将激活我希望它完美激活的链接.如果我在创建规则时说要将其应用于收件箱中的所有现有邮件，则它可以正常工作.但是，在需要的地方，在收到新消息时就不需要.
我知道脚本不会被触发，因为如果我有这样的规则:
作为播放声音"的一部分，当消息从两个指定的发件人中的任何一个到达时，声音总是播放，因此规则被触发.我从规则中删除了声音部分，并将其集成到VBA代码中以进行测试:
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
如果在所有情况下都触发了VBA脚本，则应播放"chimes.wav"，如果发生实际的链接激活处理，则应播放"TrainWhistle.wav".当收到新消息时，这两种消息均不会发生，但是，如果Outlook规则上存在播放声音"，则应运行此脚本以播放声音.
目前，我具有宏的信任中心设置，以允许所有宏，因为Outlook在测试过程的早期就对使用selfcert.exe进行签名持怀疑态度.我真的很想能够再次提升宏保护，而不是在完成所有保护后将它们保留为全部运行".
但是，最重要的是，我无法终生弄清楚为什么该脚本可以通过调试器完美运行，或者如果应用于现有消息，则不会被适用于现有消息的相同Outlook规则触发，实际的新消息到来.在我正在开发此脚本的Outlook 2010中以及在要部署该脚本的朋友的计算机上的Outlook 2016中，都是如此.
对于解决此问题的任何指导将深表感谢.
这是最终起作用的代码.显然，直到有某种幕后处理发生之前，olMail的.Body成员才可用，并且如果您没有等待足够长的时间，则在进行使用它的测试时就不会出现.专注于Public Sub OpenLinksMessage
显然，允许进行处理的主要更改是添加了以下代码行:Set InspectMail = olMail.GetInspector.CurrentItem.运行此set语句所花费的时间使.Body在Outlook规则传递的olMail参数上变得可用.有趣的是，如果立即在set语句之后显示InspectMail.Body，则它显示为空，就像olMail.Body过去一样.
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
特别感谢 niton 的耐心和帮助.
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.
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“运行脚本"规则不触发传入消息的VBA脚本的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
