Outlook「運行腳本」規則不觸發傳入郵件的VBA腳本

Question

我在另一個成員的建議中創建這個新主題。有關事情如何到達的更多歷史記錄，請參閱this question。

我有這個VBA腳本，我知道工程如果它被觸發。如果我使用TestLaunch子例程，並且在我的收件箱中已經有符合規則條件的消息（但當然不會被規則啓動），它會激活我希望它完美啓動的鏈接。如果我在創建規則時將其應用於收件箱中的所有現有郵件，它的工作原理完美無瑕。但是，在需要的地方，新消息到達它不。

我知道劇本沒有被觸發，因爲如果我有這樣一個規則：

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

與「播放聲音」作爲它的一部分，聲音始終發揮當郵件到達來自兩個指定發件人中的任何一個，所以規則正在被觸發。我已刪除的聲音從規則玩的一部分，並將其集成到用於測試目的的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 

應發揮「CHIMES.WAV」如果VBA腳本在所有情況下觸發，玩「 TrainWhistle.wav「，如果我的實際鏈接激活處理髮生。當新消息到達時，兩者都不會發生，但是如果Outlook規則中有一個「播放聲音」，應該運行該聲音播放的腳本。

目前我的信任中心設置爲允許所有的宏，因爲Outlook在測試過程中早些時候對使用selfcert.exe進行簽名時很煩躁。我真的希望能夠再次提升宏觀保護，而不是在完成這些工作時讓他們保持「全部運行」。

但是，首先，我不能爲了我的生活找出爲什麼這個腳本可以通過調試器完美運行，或者如果應用於現有的消息，但不是由應用於現有消息的完全相同的Outlook規則觸發的一個實際的新消息到達。在Outlook 2010中，我正在開發此腳本，並且也在Outlook 2016下，在正在部署它的朋友的計算機上，這種情況屬實。

有關解決此問題的任何指導將不勝感激。

Answer 1

這裏是最後工作的代碼。很明顯，olMail的.Body成員在某種幕後處理已經有時間發生之前不可用，並且如果您沒有等足夠長時間，那麼當您使用它進行測試時，它不會存在。關注公共子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 

特別感謝氡他的耐心和幫助。