在收件箱和 Outlook 中的所有子文件夹中接收电子邮件时运行 Python 脚本

Question

我在 ThisOutlookSession 中有一个 VBA 脚本 我想在电子邮件到达我的收件箱时调用 Python 脚本。

我的收件箱有规则将来自特定发件人的电子邮件移动到子文件夹中。当收到一封应用了规则的电子邮件时，我的 Python 脚本不会被调用。

我看过一些解决方案，但它们似乎都是硬编码的，因为子文件夹是直接引用的。我想在我的组织中使用这个设置，在那里我会有很多用户和收件箱具有不同的子文件夹结构，所以我正在寻找一个不太硬编码的解决方案。

我也明白使用规则可能不是最好的，而是直接在 VBA 脚本中实现它们的功能。由于我希望将此扩展到许多用户，同时保留他们创建新规则的能力，我不能使用这种方法，因为当用户需要新规则时，它需要太多的工作来维护。

Private WithEvents olItems As Outlook.Items

Private Sub Application_Startup()

Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olItems = olNS.GetDefaultFolder(olFolderInbox).Items

Debug.Print "Application_Startup triggered " & Now()

End Sub


Private Sub olItems_ItemAdd(ByVal item As Object)

Dim my_olMail As Outlook.MailItem

If TypeName(item) = "MailItem" Then

    Dim obj As Object
    Dim PythonExe As String
    Dim Script As String

    Set obj = VBA.CreateObject("Wscript.Shell")

    PythonExe = """C:\python"""

    Script = Environ("userprofile") & "\Python-Scripts\Outlook-Sound-Lock-Screen\play-sound.py"
    Debug.Print "Script Path: " & Script

    obj.Run "cmd /c cd /d" & PythonExe & "&& " & "python" & " " & Script, 0, True
    
    Set my_olMail = item
        Debug.Print "Sender: "; my_olMail.SenderEmailAddress & " | Subject: " & my_olMail.Subject
    Set my_olMail = Nothing
    
End If

End Sub

Answer 1

无需处理为单个文件夹触发的

ItemAdd

事件，您需要使用Outlook

NewMailEx

类的

Application

事件，该事件为Microsoft Outlook处理的每个接收项目触发一次。该项目可以是几种不同项目类型中的一种，例如，

MailItem

、

MeetingItem

或

SharingItem

。

EntryIDsCollection

字符串包含对应于该项目的条目 ID。使用

EntryIDCollection

字符串返回的条目ID调用NameSpace.GetItemFromID方法并处理项目。

NewMailEx

事件在新消息到达

Inbox

和客户端规则处理发生之前触发。这意味着新电子邮件在 Outlook 规则将其传输到任何其他文件夹之前由事件处理程序处理。但是，根据客户端计算机上的设置，在新邮件到达收件箱后，垃圾邮件过滤和将新邮件从收件箱移动到另一个文件夹的客户端规则等过程可能会异步发生。您不应该假设在这些事件触发后，收件箱中的项目数量总是会增加一个项目。

您还可以考虑在需要处理添加项目的每个文件夹上设置

ItemAdd

事件处理程序。

---

我还注意到以下一段代码包含一个问题：

Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")

olApp

对象未正确初始化的地方。使用 Outlook VBA 环境中可用的

Application

属性，而不是命名空间：

Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace

Set olApp = Application
Set olNS = olApp.GetNamespace("MAPI")

希望这是有道理的。

Answer 2

按照 Eugene Astafiev 关于使用 NewMailEx() 事件的建议，我已经能够在收件箱及其子文件夹中收到一封新电子邮件时触发我的 python 脚本。我还解决了 Eugene Astafiev 提出的与 olApp 初始化相关的问题。

Private Sub Application_Startup()

Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace

Set olApp = Application
Set olNS = olApp.GetNamespace("MAPI")

Debug.Print "Application_Startup triggered " & Now()

End Sub

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

    Dim obj As Object
    Dim PythonExe As String
    Dim Script As String

    Set obj = VBA.CreateObject("Wscript.Shell")

    PythonExe = """C:\python"""

    Script = Environ("userprofile") & "\Python-Scripts\Outlook-Sound-Lock-Screen\play-sound.py"

    obj.Run "cmd /c cd /d" & PythonExe & "&& " & "python" & " " & Script, 0, True

End Sub