首页 文章

Outlook“运行脚本”规则不会触发传入消息的 VBA 脚本

提问于
浏览 次
0

我正在根据另一位成员的建议创建这个新主题。有关此时如何到达的其他历史记录，请参见这个问题。

我有这个 VBA 脚本，如果触发它，我知道它可以工作。如果我使用 TestLaunch 子例程，但收件箱中已有一条符合规则标准的消息(但是，当然，不是被规则打消的)，它将激活我希望它完美激活的链接。如果我在创建规则时说要将其应用于收件箱中的所有现有邮件，则它可以完美地工作。但是，在需要的地方，不需要新消息。

我知道脚本不会被触发，因为如果我有这样的规则：

启用了“播放声音”的 Outlook“新消息”规则

作为“播放声音”的一部分，当消息从两个指定的发件人中的任何一个到达时，声音总是播放，因此将触发该规则。我从规则中删除了声音部分，并将其集成到 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 下，都是如此。

对于解决此问题的任何指导将不胜感激。

outlook system-calls outlook-vba text-parsing eventtrigger

1 回答

  • 0

    这是最终起作用的代码。显然，直到有某种幕后处理发生之前，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

    特别感谢** niton 的耐心和协助。

    回复于

相关问题